#lang racket/base

(provide schema->module-stx
         (struct-out schema-compiler-options)
         (struct-out schema-translation-paths)
         fold-Schema-definitions
         map-Schema-definitions)

(require preserves)
(require racket/match)
(require (only-in racket/list append-map))
(require (only-in racket/string string-join))
(require (only-in racket/format ~a))
(require (only-in racket/syntax format-symbol))

(require "type.rkt")
(require "parser.rkt")
(require "unparser.rkt")
(require "checker.rkt")
(require "gen/schema.rkt")

(struct schema-compiler-options (name
                                 lookup-module-path
                                 translation-paths)
  #:transparent)

(struct schema-translation-paths (full-input-path
                                  relative-input-path
                                  full-output-path
                                  relative-output-path)
  #:transparent)

(define (struct-stx name field-names more)
  `(struct ,name ,field-names #:transparent
     ,@more))

(define (ty->struct-field-names ty)
  (match ty
    [(ty-record fields) (map ty-field-name fields)] ;; not escaped here
    [(ty-unit) '()]
    [_ '(value)]))

(define (fold-Schema-definitions kc kn schema)
  (foldr (lambda (entry acc) (kc (car entry) (cdr entry) acc))
         kn
         (sorted-dict-entries (Definitions-value (Schema-definitions schema)))))

(define (map-Schema-definitions proc schema)
  (fold-Schema-definitions (lambda (n p acc) (cons (proc n p) acc)) '() schema))

(define (module-imports name schema lookup-module-path translation-paths)
  (define imports (make-hash))
  (define (import-ref! r)
    (match-define (Ref (ModulePath module-path) _name) r)
    (when (not (null? module-path))
      (hash-set! imports module-path #t)))
  (define (walk x)
    (match (unwrap x)
      [(Definition-Pattern p) (walk p)]
      [(Definition-or p0 p1 pN) (for-each walk (list* p0 p1 pN))]
      [(Definition-and p0 p1 pN) (for-each walk (list* p0 p1 pN))]
      [(Binding n p) (walk p)]
      [(NamedAlternative _ p) (walk p)]
      [(SimplePattern-seqof p) (walk p)]
      [(SimplePattern-setof p) (walk p)]
      [(SimplePattern-dictof kp vp)
       (walk kp)
       (walk vp)]
      [(SimplePattern-Ref r) (import-ref! r)]
      [(? SimplePattern?) (void)]
      [(CompoundPattern-rec label-named-pat fields-named-pat)
       (walk label-named-pat)
       (walk fields-named-pat)]
      [(CompoundPattern-tuple named-pats)
       (for-each walk named-pats)]
      [(CompoundPattern-tuplePrefix fixed-named-pats variable-named-pat)
       (for-each walk fixed-named-pats)
       (walk variable-named-pat)]
      [(CompoundPattern-dict (DictionaryEntries entries))
       (for-each walk (map cdr (sorted-dict-entries entries)))]
      [x (error 'module-imports "Unimplemented: ~v" x)]))
  (match (Schema-embeddedType schema)
    [(EmbeddedTypeName-false) (void)]
    [(EmbeddedTypeName-Ref r) (import-ref! r)])
  (map-Schema-definitions (lambda (n p) (walk p)) schema)
  (for/list [(import (in-hash-keys imports))]
    (match (lookup-module-path import)
      [#f (error 'module-imports
                 "Reference to unknown module ~a in module ~a~a"
                 (string-join (map symbol->string import) ".")
                 name
                 (match translation-paths
                   [(schema-translation-paths _ (? path-string? p) _ _) (format " (~a)" p)]
                   [_ ""]))]
      [path `(require (prefix-in ,(module-path-prefix import) ,path))])))

(define (embedded-defs schema)
  (match (Schema-embeddedType schema)
    [(EmbeddedTypeName-false) `((define :decode-embedded values)
                                (define :encode-embedded values))]
    [(EmbeddedTypeName-Ref r) `((define :decode-embedded ,(Ref-parser!-name r))
                                (define :encode-embedded ->preserve))]))


(define (parse!-definition name)
  `(define ,(format-symbol "parse-~a!" name)
     (parse-success-or-error ',(format-symbol "parse-~a" name)
                             ,(format-symbol "parse-~a" name))))

(define ((compile-definition plugins) name def acc)
  (define ty (definition-ty def))
  (match def

    [(? Definition-or?)
     (define variants (ty-union-variants ty))

     `[ (define (,(format-symbol "~a?" name) p)
          (or ,@(for/list [(variant (in-list variants))]
                  `(,(format-symbol "~a-~a?" name (ty-variant-name variant)) p))))

        ,@(for/list [(variant (in-list variants))]
            (match-define (ty-variant variant-name variant-ty variant-pat) variant)
            (define full-name (format-symbol "~a-~a" name variant-name))
            (struct-stx full-name
                        (ty->struct-field-names variant-ty)
                        `[ #:methods gen:preservable
                           [(define/generic *->preserve ->preserve)
                            (define (->preserve preservable)
                              (match preservable
                                [,(deconstruct full-name variant-ty)
                                 ,(pattern->unparser variant-pat 'src)]))]

                           ]))

        (define (,(format-symbol "parse-~a" name) input)
          (match input
            ,@(for/list [(variant (in-list variants))]
                (match-define (ty-variant variant-name variant-ty variant-pat) variant)
                `[,(pattern->match-pattern variant-pat 'dest)
                  ,(construct (format-symbol "~a-~a" name variant-name) variant-ty)])
            [_ eof]))
        ,(parse!-definition name)

        ,@acc ]]

    [(Definition-and p0 p1 pN)
     (define facets (list* p0 p1 pN))

     `[ ,(struct-stx name
                     (ty->struct-field-names ty)
                     `[ #:methods gen:preservable
                        [(define/generic *->preserve ->preserve)
                         (define (->preserve preservable)
                           (match preservable
                             [,(deconstruct name ty)
                              (merge-preserves
                               (lambda (a b) (if (equal? a b)
                                                 a
                                                 (error 'merge-preserves "Cannot merge")))
                               ,@(append-map
                                  (lambda (named-pat)
                                    (match named-pat
                                      [(NamedPattern-anonymous (Pattern-SimplePattern _)) '()]
                                      [_ (list (pattern->unparser named-pat 'src))]))
                                  facets))]))]
                        ])

        (define (,(format-symbol "parse-~a" name) input)
          (match input
            [(and ,@(for/list [(named-pat facets)] (pattern->match-pattern named-pat '_)))
             ,(construct name ty)]
            [_ eof]))
        ,(parse!-definition name)

        ,@acc ]]

    [(Definition-Pattern pattern)
     `[ ,(struct-stx name
                     (ty->struct-field-names ty)
                     `[ #:methods gen:preservable
                        [(define/generic *->preserve ->preserve)
                         (define (->preserve preservable)
                           (match preservable
                             [,(deconstruct name ty)
                              ,(pattern->unparser pattern 'src)]))]
                        ])

        (define (,(format-symbol "parse-~a" name) input)
          (match input
            [,(pattern->match-pattern pattern 'dest)
             ,(construct name ty)]
            [_ eof]))
        ,(parse!-definition name)

        ,@acc ]]))

(define (deconstruct name ty)
  (match ty
    [(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
    [(ty-unit) `(,name)]
    [_ `(,name src)]))

(define (construct name ty)
  (match ty
    [(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
    [(ty-unit) `(,name)]
    [_ `(,name dest)]))

(define (schema->module-stx name lookup-module-path schema
                            #:translation-paths [translation-paths #f]
                            #:plugins [plugins '()]
                            )
  (schema-check-problems! schema #:name name)
  (define options (schema-compiler-options name lookup-module-path translation-paths))
  `(module ,name racket/base
     (provide (except-out (all-defined-out) :decode-embedded :encode-embedded)
              (rename-out [:decode-embedded ,(format-symbol "decode-embedded:~a" name)]
                          [:encode-embedded ,(format-symbol "encode-embedded:~a" name)]))

     (require preserves)
     (require preserves-schema/methods)
     (require preserves-schema/support)
     (require racket/match)
     (require racket/set)
     (require racket/dict)
     (require (only-in racket/generic define/generic))
     ,@(module-imports name schema lookup-module-path translation-paths)
     ,@(embedded-defs schema)
     ,@(fold-Schema-definitions (compile-definition plugins) '() schema)
     ,@(for/list [(plugin (in-list plugins))] ((plugin 'schema) schema options))
     ))

(module+ main
  (require racket/pretty)
  (require racket/runtime-path)
  (require racket/path)

  (define-runtime-path schema-dir "../../../../schema")
  (define schema-file "schema.bin")
  (define schema-binary (build-path schema-dir schema-file))
  (define target "gen/schema.rkt")

  (define metaschema (parse-Schema (with-input-from-file schema-binary read-preserve)))
  (define metaschema-module-source
    (schema->module-stx 'gen-schema
                        (lambda (module-path) #f)
                        metaschema
                        #:translation-paths (schema-translation-paths schema-binary
                                                                      schema-file
                                                                      (simple-form-path target)
                                                                      target)))

  (if #t
      (with-output-to-file target #:exists 'replace
        (lambda () (pretty-write metaschema-module-source)))
      (pretty-write metaschema-module-source)))