#lang racket/base
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021-2024 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/dataspacePatterns]
      ['meta (lookup-module-path '(dataspacePatterns))]))
  (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-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-discard)))

    (define (pat-pattern p)
      (match (unwrap p)
        [(Binding name (SimplePattern-embedded _)) `(:pattern ,(escape name) embedded)]
        [(Binding name p) `(:pattern ,(escape name))]
        [(SimplePattern-any) discard]
        [(SimplePattern-atom _atomKind) discard]
        [(SimplePattern-embedded _interface) discard]
        [(SimplePattern-lit value)
         (if (eq? value '...)
             `(,(N 'Pattern-lit) (quote (... ...)))
             `(,(N 'Pattern-lit) ',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))
            `(:pat:rec ',label (list ,@(map pat-pattern field-pats)))]
           [((Binding name _) (CompoundPattern-tuple field-pats))
            `(:pat:rec ,(escape name) (list ,@(map pat-pattern field-pats)))]
           [(_ _)
            `#,(raise-syntax-error ',name "Record schema cannot be used as a pattern")])]
        [(CompoundPattern-tuple pats)
         `(:pat:arr (list ,@(map pat-pattern pats)))]
        [(CompoundPattern-tuplePrefix fixed-pats variable-pat)
         `#,(raise-syntax-error ',name "Variable-length array cannot be used as a pattern")]
        [(CompoundPattern-dict (DictionaryEntries entries))
         `(:pat:dict (hash ,@(append* (for/list [((k p) (in-hash entries))]
                                        (define s (pat-pattern p))
                                        `(',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
               ,(format-symbol "parse-~a" 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
                            ,(format-symbol "parse-~a" 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 (prefix-in :pat: syndicate/smart-pattern))
      (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)))