#lang racket/base

(provide schema->module-stx)

(require preserves)
(require racket/match)
(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 "gen/schema.rkt")

(define (struct-stx name-pieces field-names)
  `(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab))

(define (struct-defs schema)
  (reverse (for/fold [(acc '())]
                     [((name def) (in-hash (Schema-definitions schema)))]
             (match (definition-ty def)
               [(ty-union variants)
                (for/fold [(acc (cons `(define (,(format-symbol "~a?" name) p)
                                         (or ,@(for/list [(variant (in-list variants))]
                                                 `(,(format-symbol "~a-~a?" name (car variant)) p))))
                                      acc))]
                          [(variant (in-list variants))]
                  (match-define (list variant-name variant-ty) variant)
                  (match variant-ty
                    [(ty-record fields)
                     (cons (struct-stx (list name variant-name) (map car fields)) acc)]
                    [(ty-unit)
                     (cons (struct-stx (list name variant-name) '()) acc)]
                    [_
                     (cons (struct-stx (list name variant-name) '(value)) acc)]))]
               [(ty-record fields)
                (cons (struct-stx (list name) (map car fields)) acc)]
               [_
                acc]))))

(define (parser-defs schema)
  (for/list [((name def) (in-hash (Schema-definitions schema)))]
    (definition-parser name def)))

(define (unparser-defs schema)
  (for/list [((name def) (in-hash (Schema-definitions schema)))]
    (definition-unparser name def)))

(define (schema->module-stx name schema)
  `(module ,name racket/base
     (provide (all-defined-out))
     (require preserves)
     (require preserves-schema/support)
     (require racket/match)
     (require racket/set)
     (require racket/dict)
     ,@(struct-defs schema)
     ,@(parser-defs schema)
     ,@(unparser-defs schema)
     ))

(module+ main
  (require racket/pretty)
  (define metaschema-module-source
    (schema->module-stx
     'gen-schema
     (parse-Schema
      (with-input-from-file "../../../../schema/schema.bin" read-preserve))))
  (if #t
      (with-output-to-file "gen/schema.rkt" #:exists 'replace
        (lambda () (pretty-write metaschema-module-source)))
      (pretty-write metaschema-module-source)))