106 lines
4.2 KiB
Racket
106 lines
4.2 KiB
Racket
#lang racket/base
|
|
|
|
(provide schema-compiler-plugin)
|
|
|
|
(require racket/pretty)
|
|
(require racket/match)
|
|
(require (only-in racket/file make-parent-directory*))
|
|
(require (only-in racket/syntax format-symbol))
|
|
(require (only-in racket/list append* append-map))
|
|
|
|
(require preserves-schema/compiler)
|
|
(require preserves-schema/type)
|
|
(require preserves-schema/gen/schema)
|
|
|
|
(define (schema-compiler-plugin schema options)
|
|
(match-define (schema-compiler-options _name
|
|
lookup-module-path
|
|
paths) options)
|
|
(define ds-path (lookup-module-path '(dataspace-patterns)))
|
|
(define meta? (equal? ds-path (schema-translation-paths-relative-output-path paths)))
|
|
|
|
(define (N sym)
|
|
(if meta?
|
|
sym
|
|
(format-symbol ":pat:~a" sym)))
|
|
|
|
(define (def-pattern name def)
|
|
(define discard `(,(N 'DDiscard)))
|
|
|
|
(define (pat-pattern p)
|
|
(match (unwrap p)
|
|
[(NamedSimplePattern_ name p)
|
|
`(:pattern ,(escape name))]
|
|
[(SimplePattern-any) discard]
|
|
[(SimplePattern-atom _atomKind) discard]
|
|
[(SimplePattern-embedded _interface) discard]
|
|
[(SimplePattern-lit value) `(,(N 'DLit) ',value)]
|
|
[(SimplePattern-seqof pat) discard]
|
|
[(SimplePattern-setof pat) discard]
|
|
[(SimplePattern-dictof key-pat value-pat) discard]
|
|
[(SimplePattern-Ref (Ref module-path name))
|
|
`(:pattern-ref ,(format-symbol "~a~a" (module-path-prefix module-path) name))]
|
|
[(CompoundPattern-rec label-pat fields-pat)
|
|
(match* ((unwrap label-pat) (unwrap fields-pat))
|
|
[((SimplePattern-lit label) (CompoundPattern-tuple field-pats))
|
|
`(,(N 'DCompound-rec)
|
|
',label
|
|
,(length field-pats)
|
|
(hasheqv ,@(append* (for/list [(i (in-naturals))
|
|
(p (in-list field-pats))]
|
|
(define s (pat-pattern p))
|
|
(if (equal? s discard)
|
|
`()
|
|
`(,i ,s))))))]
|
|
[(_ _) `#,(raise-syntax-error ',name "Record schema cannot be used as a pattern")])]
|
|
[(CompoundPattern-tuple pats)
|
|
`(,(N 'DCompound-arr)
|
|
,(length pats)
|
|
(hasheqv ,@(append* (for/list [(i (in-naturals))
|
|
(p (in-list pats))]
|
|
(define s (pat-pattern p))
|
|
(if (equal? s discard)
|
|
`()
|
|
`(,i ,p))))))]
|
|
[other (error 'pat-pattern "Unimplemented: ~v" other)]))
|
|
|
|
(define fields (match (definition-ty def)
|
|
[(ty-unit) '()]
|
|
[(ty-record fields) (map escape (map car fields))]
|
|
[_ #f]))
|
|
|
|
(if (not fields)
|
|
`(begin)
|
|
`(define-preserves-pattern (,name ,@fields)
|
|
,@(match def
|
|
[(? Definition-or?)
|
|
`((raise-syntax-error ',name "Union schema cannot be used as a pattern")
|
|
(quasisyntax ()))]
|
|
[(? Definition-and?)
|
|
`((raise-syntax-error ',name "Intersection schema cannot be used as a pattern")
|
|
(quasisyntax ()))]
|
|
[(Definition-Pattern p)
|
|
`((quasisyntax ,(pat-pattern p))
|
|
(append ,@(for/list [(f (in-list fields))]
|
|
`(analyse-pattern-bindings (syntax ,f)))))]))))
|
|
|
|
(define exprs
|
|
`((require (prefix-in :pat: ,ds-path))
|
|
(require syndicate/pattern)
|
|
(require (for-syntax racket/base))
|
|
,@(map-Schema-definitions def-pattern schema)))
|
|
|
|
(if meta?
|
|
(let ((output-path (path-replace-extension
|
|
(schema-translation-paths-full-output-path paths)
|
|
".meta.rkt")))
|
|
(make-parent-directory* output-path)
|
|
(with-output-to-file output-path #:exists 'replace
|
|
(lambda ()
|
|
(displayln "#lang racket/base\n")
|
|
(for [(e (in-list exprs))]
|
|
(pretty-write e)
|
|
(newline))))
|
|
`(begin))
|
|
`(begin ,@exprs)))
|