#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 "type.rkt")
(require "parser.rkt")
(require "unparser.rkt")

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

(define (schema-definition-table schema)
  (match schema
    [(record 'schema (list (hash-table ('definitions definition-table) (_ _) ...)))
     definition-table]))

(define (struct-defs schema)
  (reverse (for/fold [(acc '())]
                     [((name def) (in-hash (schema-definition-table schema)))]
             (match (definition-ty def)
               [(ty-union variants)
                (for/fold [(acc 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-definition-table schema)))]
    (definition-parser name def)))

(define (unparser-defs schema)
  (for/list [((name def) (in-hash (schema-definition-table 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)
  (with-output-to-file "gen-schema.rkt" #:exists 'replace
    (lambda ()
      (pretty-write
       (schema->module-stx
        'gen-schema
        (with-input-from-file "../../../../schema/schema.bin" read-preserve))))))