#lang racket/base
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

(provide schema-compiler-plugin
         schema-compiler-plugin-mode)

(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-mode (make-parameter 'normal))

(define (schema-compiler-plugin method)
  (match method
    ['schema schema-compiler-plugin/schema]))

(define (schema-compiler-plugin/schema schema options)
  (match-define (schema-compiler-options _name
                                         lookup-module-path
                                         paths) options)
  (define ds-path
    (match (schema-compiler-plugin-mode)
      ['normal 'syndicate/schemas/gen/dataspace-patterns]
      ['meta (lookup-module-path '(dataspace-patterns))]))
  (define meta?
    (match (schema-compiler-plugin-mode)
      ['normal #f]
      ['meta (equal? ds-path (schema-translation-paths-relative-output-path paths))]))

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

  (define (final-atom-destructurer pat)
    (when (not (SimplePattern? pat))
      (error 'final-atom-destructurer "Internal error: got ~v" pat))
    (match pat
      [(SimplePattern-any) `values]
      [(SimplePattern-atom atomKind)
       `(lambda (stx) #`(? ,(match atomKind
                              [(AtomKind-Boolean) `boolean?]
                              [(AtomKind-Float) `float?]
                              [(AtomKind-Double) `double-flonum?]
                              [(AtomKind-SignedInteger) `integer?]
                              [(AtomKind-String) `string?]
                              [(AtomKind-ByteString) `bytes?]
                              [(AtomKind-Symbol) `symbol?])
                           #,stx))]
      [(SimplePattern-embedded _interface)
       `(lambda (stx) #`(embedded #,stx))]
      [(SimplePattern-lit value) `values]
      [(SimplePattern-seqof pat) `values]
      [(SimplePattern-setof pat) `values]
      [(SimplePattern-dictof key-pat value-pat) `values]
      [(SimplePattern-Ref (Ref (ModulePath module-path) name)) `values]))

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

    (define (pat-pattern p)
      (match (unwrap p)
        [(NamedSimplePattern_ name (SimplePattern-embedded _))
         `(:pattern ,(escape name) embedded)]
        [(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 (ModulePath 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) fields]
                      [_ #f])))
        (if (not fields)
            (k-nonrecord)
            `(define-preserves-pattern ,top-name (,name ,@(map escape (map ty-field-name fields)))
               (quasisyntax ,(pat-pattern p))
               (append ,@(for/list [(f (in-list fields))]
                           `(map ,(final-atom-destructurer (unwrap (ty-field-pattern f)))
                                 (analyse-pattern-bindings
                                  (syntax ,(escape (ty-field-name f)))))))))))

    (match def
      [(Definition-or p0 p1 pN)
       `(begin ,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
                            (alt-ty (in-list (map ty-variant-type (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)
                                 (map ,(final-atom-destructurer (unwrap pattern))
                                      (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)))
