#lang racket/base

(provide schema-compiler-plugin)

(require racket/pretty)
(require racket/match)
(require (only-in racket/file make-parent-directory*))
(require (only-in racket/syntax format-symbol))
(require (only-in racket/list append* append-map))

(require preserves-schema/compiler)
(require preserves-schema/type)
(require preserves-schema/gen/schema)

(define (schema-compiler-plugin schema options)
  (match-define (schema-compiler-options _name
                                         lookup-module-path
                                         paths) options)
  (define ds-path (lookup-module-path '(dataspace-patterns)))
  (define meta? (equal? ds-path (schema-translation-paths-relative-output-path paths)))

  (define (N sym)
    (if meta?
        sym
        (format-symbol ":pat:~a" sym)))

  (define (def-pattern name def)
    (define discard `(,(N 'Pattern-DDiscard) (,(N 'DDiscard))))

    (define (pat-pattern p)
      (match (unwrap p)
        [(NamedSimplePattern_ name p)
         `(:pattern ,(escape name))]
        [(SimplePattern-any) discard]
        [(SimplePattern-atom _atomKind) discard]
        [(SimplePattern-embedded _interface) discard]
        [(SimplePattern-lit value) `(,(N 'Pattern-DLit) (,(N 'DLit) ',value))]
        [(SimplePattern-seqof pat) discard]
        [(SimplePattern-setof pat) discard]
        [(SimplePattern-dictof key-pat value-pat) discard]
        [(SimplePattern-Ref (Ref module-path name))
         `(:pattern-ref ,(format-symbol "~a~a" (module-path-prefix module-path) name))]
        [(CompoundPattern-rec label-pat fields-pat)
         (match* ((unwrap label-pat) (unwrap fields-pat))
           [((SimplePattern-lit label) (CompoundPattern-tuple field-pats))
            `(,(N 'Pattern-DCompound)
              (,(N 'DCompound-rec)
               ',label
               ,(length field-pats)
               (hasheqv ,@(append* (for/list [(i (in-naturals))
                                              (p (in-list field-pats))]
                                     (define s (pat-pattern p))
                                     (if (equal? s discard)
                                         `()
                                         `(,i ,s)))))))]
           [(_ _) `#,(raise-syntax-error ',name "Record schema cannot be used as a pattern")])]
        [(CompoundPattern-tuple pats)
         `(,(N 'Pattern-DCompound)
           (,(N 'DCompound-arr)
            ,(length pats)
            (hasheqv ,@(append* (for/list [(i (in-naturals))
                                           (p (in-list pats))]
                                  (define s (pat-pattern p))
                                  (if (equal? s discard)
                                      `()
                                      `(,i ,p)))))))]
        [other (error 'pat-pattern "Unimplemented: ~v" other)]))

    (define fields (match (definition-ty def)
                     [(ty-unit) '()]
                     [(ty-record fields) (map escape (map car fields))]
                     [_ #f]))

    (if (not fields)
        `(begin)
        `(define-preserves-pattern (,name ,@fields)
           ,@(match def
               [(? Definition-or?)
                `((raise-syntax-error ',name "Union schema cannot be used as a pattern")
                  (quasisyntax ()))]
               [(? Definition-and?)
                `((raise-syntax-error ',name "Intersection schema cannot be used as a pattern")
                  (quasisyntax ()))]
               [(Definition-Pattern p)
                `((quasisyntax ,(pat-pattern p))
                  (append ,@(for/list [(f (in-list fields))]
                              `(analyse-pattern-bindings (syntax ,f)))))]))))

  (define exprs
    `((require (prefix-in :pat: ,ds-path))
      (require syndicate/pattern)
      (require (for-syntax racket/base))
      ,@(map-Schema-definitions def-pattern schema)))

  (if meta?
      (let ((output-path (path-replace-extension
                          (schema-translation-paths-full-output-path paths)
                          ".meta.rkt")))
        (make-parent-directory* output-path)
        (with-output-to-file output-path #:exists 'replace
          (lambda ()
            (displayln "#lang racket/base\n")
            (for [(e (in-list exprs))]
              (pretty-write e)
              (newline))))
        `(begin))
      `(begin ,@exprs)))