#!/usr/bin/guile -s
!#
(use-modules
 (ice-9 match)
 (srfi srfi-1)
 (ice-9 format)
 (ice-9 regex)
 (ice-9 popen)
 (ice-9 rdelim)
 (ice-9 getopt-long))
(define rest cdr)

;; (define (debug . args)
;;   (format
;;    (current-error-port) "~%~{~a - ~s~%~}~%"
;;    (list 'command-line  (command-line)
;;          'target        target
;;          'rules         rules
;;          'selected-rule selected-rule
;;          'action        action)))

(define option-spec
  '((version (single-char #\v))
    (help    (single-char #\h))
    (debug   (single-char #\d))
    (load    (single-char #\l) (value #t) ;; (predicate file-exists?)
             )))

(define options (getopt-long (command-line) option-spec))

(format (current-error-port)
        "debug ~s~%"
        (option-ref options 'debug #f))

(define (debug format-string . args)
  (when (option-ref options 'debug #f)
    (apply format (current-error-port) format-string args)))

;; Return the parent directory component of PATH, or #f if none is present.
(define (parent path)
  (if path
      (let ((match (string-match (format #f "/~a$" (basename path)) path)))
        (if match (regexp-substitute #f match 'pre "/") #f))
      #f))

;; Return the basename of the current working directory.
(define (getcwd-base) (basename (getcwd)))

;; If ARG is truthy, return "-<ARG>", else return "".
(define (file-name-part arg)
  (if arg (format #f "-~a" arg) ""))

;; Return FILE name without the extension, or FILE if there is no extension.
(define (file-name-no-extension file)
  (let ((rindex (string-rindex file #\.)))
    (if rindex
        (xsubstring file 0 rindex)
        file)))

;; Create DIR if it does not exist.
;; Raise an error if DIR does exist, but is not a directory.
;; Return DIR.
(define (use-dir! dir)
  (unless (file-exists? dir)
      (mkdir dir))
  (unless (file-is-directory? dir)
    (error (format #f "File ~s already exists and is not a directory" dir)))
  dir)

;; Return the output of running COMMAND with ARGS in the system shell.
(define (shell-result command . args)
  (let* ((port   (apply open-pipe* (append `("open_read" ,command) args)))
         (output (read-line port)))
    (close-pipe port)
    output))

;; Return the current branch of the project's version control system,
;; or #f if no version control system was detected.
(define (vcs-current-branch)
  (cond ((file-exists? ".git")
         ;; we were using `git rev-parse --abbrev-ref HEAD' before,
         ;; but that sometimes resulted in an error - `fatal:
         ;; ambiguous argument 'HEAD': unknown revision or path not in
         ;; the working tree.'
         (shell-result "git" "symbolic-ref" "--short" "HEAD"))
        ((file-exists? ".hg")
         (shell-result "hg" "identify" "-b"))
        ;; ((or (file-exists? ".fslckout")
        ;;      (file-exists? "_FOSSIL_")))
        ;; ((file-exists? ".bzr"))
        ;; ((file-exists? "_darcs"))
        ;; ((file-exists? ".svn"))
        (else #f)))

(define (flatten seq)
  (cond ((null? seq) '())
        ((not (pair? seq)) (list seq))
        (else (append (flatten (car seq))
                      (flatten (rest seq))))))

;; Flatten and convert list ARG to a string, with each element
;; separated by spaces.
(define (list->command-line arg)
  (format #f "~{~s ~}" (flatten arg)))

;; Run ARG in the system shell. ARG must be a list with elements of
;; any type. Return the exit status.
(define (run arg)
  ;; (format (current-error-port) "~%mkly: run: ~s~2%" (list->command-line arg))
  (system (list->command-line arg)))

(let ((load-values (option-ref options 'load #f)))
  (cond ((not load-values) #f)
        ((pair? load-values)
         (debug "loading files ~s~%" load-values)
         (map load load-values))
        (else
         (load load-values)
         (debug "loading file ~s~%" load-values))))

(define shell-path "/usr/bin/bash")
(define project-root (getcwd))
(define project-name (getcwd-base))

;; Return a list of build rules.
;;
;; TARGET is a single target passed on the command line, or "" if none
;; was supplied. (If multiple targets are passed on the command line,
;; this function will be called once with each target.)
;;
;; Return value is a list of rules, where each rule is a list in
;; the form (PATTERN COMMAND [ARG ...])
;;
;; PATTERN can be
;; * a symbol - COMMAND will be run when the target passed on the
;;              command line matches this symbol;
;; * a string - treated as a regular expression; COMMAND will be run
;;              when it matches the target passed on the command line
;;
;; COMMAND and arguments can be any value - lists will be flattened,
;; all values will be converted to strings, and spaces will be added.
;; String values will be quoted, which is useful for escaping file
;; names in the final command to be run.
(define (rules target)
  ;; if TARGET is a subdirectory in the project root, descend to it
  ;; before executing the action
  (let* ((subdir (parent target))
         (branch (vcs-current-branch))
         (dest   (begin
                   (when subdir
                     (chdir subdir)
                     (set! project-name (getcwd-base)))
                   (use-dir! (format #f "~:[output-~a~;output/~]" branch branch)))))
    ;; A main.ly could also exist both in the root and in the
    ;; sub-directories, but this will just compile the root main.ly regardless.
    `((all main.ly part-*.ly)
      (dev lilypond
           -o ,(string-append dest project-name "-pacON")
           main.ly)
      (main.ly lilypond -dno-point-and-click
               -o ,(string-append dest project-name)
               ,target)
      ("part-.*\\.ly" lilypond -dno-point-and-click
                      -o ,(string-append
                           dest project-name "-" (file-name-no-extension target))
                      ,target))))

;; Return a rule from RULES which matches TARGET
;;
;; RULES must be a list (see procedure `rules'), where each element is
;; in the form (PATTERN COMMAND [ARGS ...])
;;
;; TARGET must be a string.
;;  If it is empty, return the first rule in RULES.
;;  If it is `equal?' to a PATTERN string or to the name of a PATTERN
;;  symbol, or if TARGET is matched by a PATTERN regular expression,
;;  return the rule whose TARGET matched.
(define (select-rule rules target)
  (if (null? rules)
      (begin (debug "mkly: no matching rule") #f)
      (let* ((rule         (first rules))
             (pattern      (first rule))
             (rule-command (rest rule)))
        ;; (format (current-error-port) "~%rule - ~s~%pattern - ~s~%" rule target)
        (cond ((equal? "" target) rule)
              ((and (string? pattern)
                    (string-match pattern target))
               ;; (format #t "~%mkly: running ~s~%" rule-command)
               rule)
              ((and (symbol? pattern)
                    (equal? target (symbol->string pattern)))
               ;; (format #t "~%mkly: running ~s~%" rule-command)
               rule)
              (else (select-rule (rest rules) target))))))

;; target ::= action -> run
;;         | target  -> for each target, recurse with new target
(define (run-rule-for target)
  (let* ((rules         (rules target))
         (selected-rule (flatten (select-rule rules target)))
         ;; Support for actions which call mkly itself. Do we really want this?
         (action        (if (equal? "./mkly" (first (command-line)))
                            (map (lambda (it)
                                   (if (or (eq? it 'mkly)
                                           (equal? it "mkly"))
                                       (string-append (getcwd) "/mkly")
                                       it))
                                 (rest selected-rule))
                            (rest selected-rule))))
    (debug "~%~{~a - ~s~%~}~%"
           (list 'command-line  (command-line)
                 'rules         rules
                 'selected-rule selected-rule
                 'action        action))
    (system (list->command-line action))))

;; Run the associated action for each element of TARGETS.
;;
;; TARGETS must be a list of strings, representing all non-option
;; arguments passed by the user to the script on the command line.
(define (main targets)
  (debug "targets - ~s~%" targets)
  (let loop ((targets targets))
    (let ((target  (if (null? targets) "" (first targets))))
      (debug "running rule ~a for target ~s~%"
             (select-rule (rules target) target) target)
      (if (and (file-exists? target)
               (file-is-directory? target))
          (begin (chdir project-root)
                 (chdir target))
          (run-rule-for target))
      (when (pair? targets)
        (loop (rest targets))))))

(main (option-ref options '() #f))