#lang racket/base

(provide batch-compile load-plugins)

(require "../compiler.rkt")
(require "../reader.rkt")
(require racket/match)
(require racket/pretty)
(require (only-in racket/list index-of append-map remove-duplicates last drop-right))
(require (only-in racket/string string-split string-prefix?))
(require (only-in racket/file make-parent-directory*))
(require file/glob)

(struct schema (paths
                module-path
                value)
  #:transparent)

(define (clean-input p)
  (path->string (simplify-path (path->complete-path (expand-user-path p)) #f)))

(define (expand-globs globs base0 output-directory0)
  (for/list [(entry (in-list (remove-duplicates
                              #:key car
                              (append-map (lambda (g)
                                            (define results (glob g))
                                            (when (null? results)
                                              (error 'preserves-schema-rkt
                                                     "Input not found: ~v" g))
                                            (map (lambda (r) (list (path->string r) g))
                                                 results))
                                          globs))))]
    (match-define (list full-input-path generating-glob) entry)
    (define base (or base0 (path->string (simplify-path (build-path generating-glob 'up) #f))))
    (define output-directory (or (and output-directory0 (clean-input output-directory0)) base))

    (when (not (string-prefix? full-input-path base))
      (error 'preserves-schema-rkt "Input filename ~v falls outside base ~v"
             full-input-path
             base))

    (define relative-input-path (substring full-input-path (string-length base)))
    (define module-path (for/list [(p (explode-path relative-input-path))]
                          (string->symbol (path->string (path-replace-extension p "")))))
    (define relative-output-path
      (path->string (path-replace-extension relative-input-path ".rkt")))
    (log-info "Loading Preserves Schema file ~s" full-input-path)
    (schema (schema-translation-paths full-input-path
                                      relative-input-path
                                      (path->string (build-path output-directory relative-output-path))
                                      relative-output-path)
            module-path
            (file->schema full-input-path))))

(define (batch-compile #:inputs inputs
                       #:additional-modules [additional-modules (hash)]
                       #:base-directory [base-directory #f]
                       #:output-directory [output-directory #f]
                       #:write-files? [write-files? #t]
                       #:plugins [plugins '()])
  (define schemas (expand-globs inputs base-directory output-directory))

  (define index
    (for/fold [(index additional-modules)]
              [(s (in-list schemas))]
      (hash-set index
                (schema-module-path s)
                (schema-translation-paths-relative-output-path (schema-paths s)))))

  (define outputs
    (for/hash [(s (in-list schemas))]
      (match-define (schema (and tps (schema-translation-paths fi ri fo ro)) mp v) s)
      (values fo
              (schema->module-stx
               (last mp)
               (lambda (module-path) (hash-ref index module-path #f))
               v
               #:translation-paths tps
               #:plugins plugins))))

  (when write-files?
    (for [((output-path stx) (in-hash outputs))]
      (make-parent-directory* output-path)
      (with-output-to-file output-path #:exists 'replace
        (lambda () (pretty-write stx)))))

  outputs)

(define (load-plugins mods)
  (for/list [(mod mods)]
    (dynamic-require mod 'schema-compiler-plugin)))

(module+ main
  (require racket/cmdline)

  (define output-directory #f)
  (define write-files? #t)
  (define stdout? #f)
  (define base-directory #f)
  (define additional-modules '())
  (define inputs '())
  (define plugin-mods '())

  (command-line #:once-each
                ["--output" directory "Output directory for modules (default: next to sources)"
                 (set! output-directory directory)]
                ["--stdout" "Prints each module to stdout one after the other instead of writing them to files in the `--output` directory"
                 (set! stdout? #t)]
                ["--no-write-files" "Disables generation of output to the filesystem"
                 (set! write-files? #f)]
                ["--base" directory "Base directory for sources (default: common prefix)"
                 (set! base-directory directory)]
                #:multi
                ["--module" namespace=path "Additional Namespace=path import"
                 (let ((i (index-of (string->list namespace=path) #\=)))
                   (when (not i)
                     (error '--module "Argument must be Namespace=path: ~v" namespace=path))
                   (let* ((namespace-str (substring namespace=path 0 i))
                          (path-str (substring namespace=path (+ i 1))))
                     (when (string-prefix? path-str ":")
                       (set! path-str (string->symbol (substring path-str 1))))
                     (set! additional-modules
                           (cons (list (map string->symbol (string-split namespace-str "."))
                                       path-str)
                                 additional-modules))))]
                [("--plugin-lib" "-l") lib-path "Load compiler plugin library"
                 (set! plugin-mods (cons (string->symbol lib-path) plugin-mods))]
                [("--plugin-file" "-f") rkt-file-path "Load compiler plugin source file"
                 (set! plugin-mods (cons rkt-file-path plugin-mods))]
                #:args input-glob
                (set! inputs (map clean-input input-glob)))

  (when (null? inputs)
    (error 'preserves-schema-rkt "No inputs specified."))

  (set! plugin-mods (reverse plugin-mods))

  (define outputs
    (batch-compile #:inputs inputs
                   #:additional-modules (for/hash [(e (in-list additional-modules))]
                                          (values (car e) (cadr e)))
                   #:base-directory base-directory
                   #:output-directory output-directory
                   #:write-files? write-files?
                   #:plugins (load-plugins plugin-mods)))

  (when stdout?
    (for [((output-path stx) (in-hash outputs))]
      (printf ";;-----------------------------------------------------------------\n")
      (printf ";; ~a\n" output-path)
      (newline)
      (pretty-write stx)
      (newline))))
