preserves/implementations/racket/preserves/preserves-schema/compiler.rkt

#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/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-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 (module-imports name schema lookup-module-path translation-paths)
  (define imports (make-hash))
  (define (import-ref! r)
    (match-define (Ref 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))]
      [(NamedSimplePattern_ 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-tuple* fixed-named-pats variable-named-pat)
       (for-each walk fixed-named-pats)
       (walk variable-named-pat)]
      [(CompoundPattern-dict 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 ,(Ref-unparser-name r)))]))

(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 ty-field-name fields)) acc)]
            [(ty-unit)
             (cons (struct-stx (list name variant-name) '()) acc)]
            [_
             (cons (struct-stx (list name variant-name) '(value)) acc)]))]
       [(ty-unit)
        (cons (struct-stx (list name) '()) acc)]
       [(ty-record fields)
        (cons (struct-stx (list name) (map ty-field-name 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 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)]))
     ,@(module-imports name schema lookup-module-path translation-paths)
     ,@(embedded-defs schema)
     (require preserves)
     (require preserves-schema/support)
     (require racket/match)
     (require racket/set)
     (require racket/dict)
     ,@(struct-defs schema)
     ,@(parser-defs schema)
     ,@(unparser-defs schema)
     ,@(for/list [(plugin (in-list plugins))] (plugin 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)))