#lang typed/racket

(provide make/proc
         argv
         string-prefix?
         string-suffix?
         find-files-by-extension
         t-rule
         rules
         ;rule
         implicit-rule
         for/rules
         path-string->string
         path-string->path
         path-append
         regexp-case
         dirname
         underscore-extension
         compile-zos
         rkt->zo-dir
         rkt->zo-file
         make-collection
         run
         run!)

(require/typed make [make/proc (→ (Listof
                                   (Pairof (U Path-String (Listof Path-String))
                                           (Pairof (Listof Path-String)
                                                   (U Null
                                                      (List (-> Any))))))
                                  (U String (Vectorof String) (Listof String))
                                  Void)])
;(require/typed make/collection [make-collection (→ Any (Listof Path-String) (U String (Vectorof String)) Void)])

(require/typed srfi/13
               [string-suffix? (->* (String String) (Integer Integer Integer Integer) Boolean)]
               [string-prefix? (->* (String String) (Integer Integer Integer Integer) Boolean)])

(define (find-files-by-extension [ext : String])
  (find-files (λ ([path : Path]) (string-suffix? ext (path->string path)))))

;(: drop-extension (→ Path-String * String String))
;(define (drop-extension path . exts)
;  (map (λ () exts)

(define-type t-rule (Pairof (U Path-String (Listof Path-String))
                            (Pairof (Listof Path-String)
                                    (U Null
                                       (List (-> Any))))))
(: rules (→ (U t-rule (Listof t-rule)) * (Listof t-rule)))
(define (rules . rs)
  (apply append (map (λ ([x : (U t-rule (Listof t-rule))])
                       (cond [(null? x) '()] ;; x = '() is an empty (Listof t-rule)
                             [(null? (cdr x)) x] ;; x = '([target dep maybe-proc]) is a (Listof t-rule) with just one element
                             [(null? (cadr x)) (list x)] ;; x = '[target () maybe-proc] is a t-rule with an empty list of dependencies
                             ;; Below, either x = '[target (dep₁ . ?) maybe-proc] or x = '([target dep maybe-proc] [target dep maybe-proc])
                             [(null? (cdadr x)) (list x)] ;; x = '[target (dep₁ . ()) maybe-proc]
                             [(list? (cadadr x)) x] ;; x = '([target dep maybe-proc] [target (?) maybe-proc])
                             [else (list x)])) ; x = '[target (dep₁ dep₂ . ()) maybe-proc]
                     rs)))

#|
(define-syntax (rule stx)
  (syntax-case stx ()
    [(_ (target ...) (depend ...) body0 . body)
     #'(list (list target ...)
             (list depend ...)
             (λ () body0 . body))]
    [(_ (target ...) (depend ...))
     #'(list (list target ...)
             (list depend ...))]))
|#

(define-syntax-rule (implicit-rule (arg ...) (target ...) (depend ...) body ...)
  (λ ([arg : Path] ...)
    (list (list target ...)
          (list depend ...)
          (λ () body ...))))

(define-syntax-rule (for/rules ([arg files] ...) (target ...) (depend ...) body ...)
  (map (implicit-rule (arg ...) (target ...) (depend ...) body ...) files ...))

(: path-string->string (→ Path-String String))
(define (path-string->string ps)
  (if (string? ps)
      ps
      (path->string ps)))

(: path-string->path (→ Path-String Path))
(define (path-string->path ps)
  (if (string? ps)
      (string->path ps)
      ps))

(: path-append (→ Path-String Path-String Path))
(define (path-append a b)
  (string->path (string-append (path-string->string a)
                               (path-string->string b))))

(define-syntax-rule (regexp-case input [pattern replacement] ...)
  (let ([input-cache input]) ;; TODO: should also cache the patterns, but lazily.
    (cond
      [(regexp-match pattern input-cache) (regexp-replace pattern input-cache replacement)]
      ...
      [else input-cache])))

(: dirname (→ Path Path))
(define (dirname p)
  (let-values ([(base name must-be-dir?) (split-path p)])
    (case base
      ['relative (build-path 'same)] ;; If the path is "..", then this is wrong.
      ['#f (error (format "Can't get parent directory of ~a" p))]
      [else base])))

(: underscore-extension (→ Path-String String * Path))
(define (underscore-extension path . ext)
  (if (null? ext)
      (path-string->path path)
      (let ([p (path-string->string path)]
            [e (path-string->string (car ext))])
        (if (string-suffix? (car ext) p)
            (let* ([pos (- (string-length p) (string-length e))]
                   [left (substring p 0 pos)])
              (string->path (string-append left (string-replace e "." "_"))))
            (apply underscore-extension path (cdr ext))))))

;; TODO: do pattern-matching on paths, with (match) ?

(define (argv)
  (let ([argv (current-command-line-arguments)])
    (if (= (vector-length argv) 0)
        #("zo")
        argv)))

;; make-collection from /usr/local/racket-6.2.900.6/share/pkgs/make/collection-unit.rkt
(require/typed compiler/compiler [compile-zos (->* (Any) (#:module? Any #:verbose? Any) (→ (Listof Path-String) (U Path-String #f 'auto) Void))])
(require/typed dynext/file [append-zo-suffix (→ Path-String Path)])

(: cache (∀ (T) (→ (→ T) (→ T))))
(define (cache producer)
  (let ([cache : (U False (List T)) #f]) ;; Use (List T) instead of T, so that if the producer returns #f, we don't call it each time.
    (λ ()
      (let ([c cache]) ;; since cache is mutated by set!, occurrence typing won't work on it, so we need to take a copy.
        (if c
            (car c)
            (let ((producer-result (producer)))
              (set! cache (list producer-result))
              producer-result))))))

(: rkt->zo-dir (→ Path-String Path))
(define (rkt->zo-dir src-file)
  (simplify-path (build-path src-file 'up "compiled") #f))

(: rkt->zo-file (→ Path-String Path))
(define (rkt->zo-file src-file)
  (build-path (rkt->zo-dir src-file) (append-zo-suffix (assert (file-name-from-path src-file)))))

(: make-collection  (→ Any (Listof Path-String) (U String (Vectorof String)) Void))
(define (make-collection collection-name collection-files argv)
  (printf "building collection ~a: ~a\n" collection-name collection-files)
  (let* ([zo-compiler (cache (λ () (compile-zos #f)))]
         [src-dir (current-directory)]
         [rkts (sort collection-files
                     (lambda ([a : Path] [b : Path])
                       (string-ci<? (path->string a) (path->string b))))]
         [zos (map (lambda ([rkt : Path-String])
                     (rkt->zo-file rkt))
                   rkts)]
         [rkt->zo-list
          (map (lambda ([rkt : Path-String] [zo : Path])
                 `(,zo (,rkt)
                       ,(lambda ()
                          (let ([dest (rkt->zo-dir rkt)])
                            (unless (directory-exists? dest) (make-directory dest))
                            ((zo-compiler) (list rkt) dest)))))
               rkts zos)])
    (make/proc (append `(("zo" ,zos)) rkt->zo-list) argv)))

(: run (→ (U Path-String (Pairof Path-String (Listof (U Path-String Bytes)))) [#:set-pwd? Any] (U Path-String Bytes) * Boolean))
(define (run arg0 #:set-pwd? [set-pwd? #f] . args)
  (if (list? arg0)
      (apply run arg0)
      (begin
        (displayln (string-append (string-join (cons (path-string->string arg0) (map (λ (x) (format "~a" x)) args)) " ")))
        (display "\033[1;34m")
        (flush-output)
        (let ((result (apply system* arg0 args)))
          (display "\033[m")
          (flush-output)
          (unless result
            (raise "Command failed."))
          result))))

(define-syntax-rule (run! . rest) (let () (run . rest) (values)))