#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)
               (,(N 'CRec) ',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)
            (,(N 'CArr) ,(length pats))
            (hasheqv ,@(append* (for/list [(i (in-naturals))
                                           (p (in-list pats))]
                                  (define s (pat-pattern p))
                                  (if (equal? s discard) `() `(,i ,p)))))))]
        [(CompoundPattern-tuple* fixed-pats variable-pat)
         `#,(raise-syntax-error ',name "Variable-length array cannot be used as a pattern")]
        [(CompoundPattern-dict entries)
         `(,(N 'Pattern-DCompound)
           (,(N 'DCompound-dict)
            (,(N 'CDict))
            (hash ,@(append* (for/list [((k p) (in-hash entries))]
                               (define s (pat-pattern p))
                               (if (equal? s discard) `() `(',k ,s)))))))]
        [other (error 'pat-pattern "Unimplemented: ~v" other)]))

    (define (top-pat top-name name p ty k-nonrecord)
      (let ((fields (match ty
                      [(ty-unit) '()]
                      [(ty-record fields) (map escape (map car fields))]
                      [_ #f])))
        (if (not fields)
            (k-nonrecord)
            `(define-preserves-pattern ,top-name (,name ,@fields)
               (quasisyntax ,(pat-pattern p))
               (append ,@(for/list [(f (in-list fields))]
                           `(analyse-pattern-bindings (syntax ,f))))))))

    (match def
      [(Definition-or p0 p1 pN)
       `(begin ,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
                            (alt-ty (in-list (map cadr (ty-union-variants (definition-ty def)))))]
                   (match-define (NamedAlternative variant-label-str pattern) named-alt)
                   (define full-name (format-symbol "~a-~a" name variant-label-str))
                   (top-pat name full-name pattern alt-ty
                            (lambda () `(define-preserves-pattern ,name (,full-name value)
                                          (analyse-pattern #'value)
                                          (analyse-pattern-bindings (syntax value)))))))]
      [(? Definition-and?)
       `(begin)]
      [(Definition-Pattern p)
       (top-pat name name p (definition-ty def) (lambda () `(begin)))]))

  (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)))