#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 "checker.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 (fold-Schema-definitions kc kn schema)
  (foldr (lambda (entry acc) (kc (car entry) (cdr entry) acc))
         kn
         (sorted-dict-entries (Schema-definitions schema))))

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

(define (struct-defs schema)
  (fold-Schema-definitions
   (lambda (name def acc)
     (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]))
   '()
   schema))

(define (parser-defs schema)
  (map-Schema-definitions definition-parsers schema))

(define (unparser-defs schema)
  (map-Schema-definitions definition-unparser schema))

(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
    (parse-Schema
     (with-input-from-file "../../../../schema/schema.bin" read-preserve)))
  (let ((problems (schema-check-problems metaschema)))
    (when (not (null? problems))
      (error 'schema-check-problems "Problems checking schema: ~v" problems)))
  (define metaschema-module-source (schema->module-stx 'gen-schema metaschema))
  (if #t
      (with-output-to-file "gen/schema.rkt" #:exists 'replace
        (lambda () (pretty-write metaschema-module-source)))
      (pretty-write metaschema-module-source)))