2021-06-02 04:57:48 +00:00
|
|
|
#lang racket/base
|
2021-06-04 14:20:14 +00:00
|
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
|
|
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
2021-06-02 04:57:48 +00:00
|
|
|
|
2021-06-03 21:22:46 +00:00
|
|
|
(provide schema-compiler-plugin
|
|
|
|
schema-compiler-plugin-mode)
|
2021-06-02 04:57:48 +00:00
|
|
|
|
2021-06-02 10:37:36 +00:00
|
|
|
(require racket/pretty)
|
2021-06-02 04:57:48 +00:00
|
|
|
(require racket/match)
|
2021-06-02 10:37:36 +00:00
|
|
|
(require (only-in racket/file make-parent-directory*))
|
|
|
|
(require (only-in racket/syntax format-symbol))
|
|
|
|
(require (only-in racket/list append* append-map))
|
|
|
|
|
2021-06-02 04:57:48 +00:00
|
|
|
(require preserves-schema/compiler)
|
2021-06-02 10:37:36 +00:00
|
|
|
(require preserves-schema/type)
|
|
|
|
(require preserves-schema/gen/schema)
|
2021-06-02 04:57:48 +00:00
|
|
|
|
2021-06-03 21:22:46 +00:00
|
|
|
(define schema-compiler-plugin-mode (make-parameter 'normal))
|
|
|
|
|
2021-06-08 13:38:24 +00:00
|
|
|
(define (schema-compiler-plugin method)
|
|
|
|
(match method
|
|
|
|
['schema schema-compiler-plugin/schema]))
|
|
|
|
|
|
|
|
(define (schema-compiler-plugin/schema schema options)
|
2021-06-02 04:57:48 +00:00
|
|
|
(match-define (schema-compiler-options _name
|
|
|
|
lookup-module-path
|
|
|
|
paths) options)
|
2021-06-03 21:22:46 +00:00
|
|
|
(define ds-path
|
|
|
|
(match (schema-compiler-plugin-mode)
|
|
|
|
['normal 'syndicate/schemas/gen/dataspace-patterns]
|
|
|
|
['meta (lookup-module-path '(dataspace-patterns))]))
|
|
|
|
(define meta?
|
|
|
|
(match (schema-compiler-plugin-mode)
|
|
|
|
['normal #f]
|
|
|
|
['meta (equal? ds-path (schema-translation-paths-relative-output-path paths))]))
|
2021-06-02 10:37:36 +00:00
|
|
|
|
|
|
|
(define (N sym)
|
|
|
|
(if meta?
|
|
|
|
sym
|
|
|
|
(format-symbol ":pat:~a" sym)))
|
|
|
|
|
2021-06-08 16:01:27 +00:00
|
|
|
(define (final-atom-destructurer pat)
|
|
|
|
(when (not (SimplePattern? pat))
|
|
|
|
(error 'final-atom-destructurer "Internal error: got ~v" pat))
|
|
|
|
(match pat
|
|
|
|
[(SimplePattern-any) `values]
|
|
|
|
[(SimplePattern-atom atomKind)
|
|
|
|
`(lambda (stx) #`(? ,(match atomKind
|
|
|
|
[(AtomKind-Boolean) `boolean?]
|
|
|
|
[(AtomKind-Float) `float?]
|
|
|
|
[(AtomKind-Double) `double-flonum?]
|
|
|
|
[(AtomKind-SignedInteger) `integer?]
|
|
|
|
[(AtomKind-String) `string?]
|
|
|
|
[(AtomKind-ByteString) `bytes?]
|
|
|
|
[(AtomKind-Symbol) `symbol?])
|
|
|
|
#,stx))]
|
|
|
|
[(SimplePattern-embedded _interface)
|
|
|
|
`(lambda (stx) #`(embedded #,stx))]
|
|
|
|
[(SimplePattern-lit value) `values]
|
|
|
|
[(SimplePattern-seqof pat) `values]
|
|
|
|
[(SimplePattern-setof pat) `values]
|
|
|
|
[(SimplePattern-dictof key-pat value-pat) `values]
|
|
|
|
[(SimplePattern-Ref (Ref (ModulePath module-path) name)) `values]))
|
|
|
|
|
2021-06-02 10:37:36 +00:00
|
|
|
(define (def-pattern name def)
|
2021-06-02 11:41:30 +00:00
|
|
|
(define discard `(,(N 'Pattern-DDiscard) (,(N 'DDiscard))))
|
2021-06-02 10:37:36 +00:00
|
|
|
|
|
|
|
(define (pat-pattern p)
|
|
|
|
(match (unwrap p)
|
2021-06-10 11:32:39 +00:00
|
|
|
[(NamedSimplePattern_ name (SimplePattern-embedded _))
|
|
|
|
`(:pattern ,(escape name) embedded)]
|
2021-06-02 10:37:36 +00:00
|
|
|
[(NamedSimplePattern_ name p)
|
|
|
|
`(:pattern ,(escape name))]
|
|
|
|
[(SimplePattern-any) discard]
|
|
|
|
[(SimplePattern-atom _atomKind) discard]
|
|
|
|
[(SimplePattern-embedded _interface) discard]
|
2021-06-02 11:41:30 +00:00
|
|
|
[(SimplePattern-lit value) `(,(N 'Pattern-DLit) (,(N 'DLit) ',value))]
|
2021-06-02 10:37:36 +00:00
|
|
|
[(SimplePattern-seqof pat) discard]
|
|
|
|
[(SimplePattern-setof pat) discard]
|
|
|
|
[(SimplePattern-dictof key-pat value-pat) discard]
|
2021-06-08 16:01:27 +00:00
|
|
|
[(SimplePattern-Ref (Ref (ModulePath module-path) name))
|
2021-06-02 10:37:36 +00:00
|
|
|
`(: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))
|
2021-06-02 11:41:30 +00:00
|
|
|
`(,(N 'Pattern-DCompound)
|
|
|
|
(,(N 'DCompound-rec)
|
2021-06-03 13:58:48 +00:00
|
|
|
(,(N 'CRec) ',label ,(length field-pats))
|
2021-06-02 11:41:30 +00:00
|
|
|
(hasheqv ,@(append* (for/list [(i (in-naturals))
|
|
|
|
(p (in-list field-pats))]
|
|
|
|
(define s (pat-pattern p))
|
2021-06-03 13:58:48 +00:00
|
|
|
(if (equal? s discard) `() `(,i ,s)))))))]
|
2021-06-02 10:37:36 +00:00
|
|
|
[(_ _) `#,(raise-syntax-error ',name "Record schema cannot be used as a pattern")])]
|
|
|
|
[(CompoundPattern-tuple pats)
|
2021-06-02 11:41:30 +00:00
|
|
|
`(,(N 'Pattern-DCompound)
|
|
|
|
(,(N 'DCompound-arr)
|
2021-06-03 13:58:48 +00:00
|
|
|
(,(N 'CArr) ,(length pats))
|
2021-06-02 11:41:30 +00:00
|
|
|
(hasheqv ,@(append* (for/list [(i (in-naturals))
|
|
|
|
(p (in-list pats))]
|
|
|
|
(define s (pat-pattern p))
|
2021-06-03 13:58:48 +00:00
|
|
|
(if (equal? s discard) `() `(,i ,p)))))))]
|
|
|
|
[(CompoundPattern-tuple* fixed-pats variable-pat)
|
|
|
|
`#,(raise-syntax-error ',name "Variable-length array cannot be used as a pattern")]
|
|
|
|
[(CompoundPattern-dict entries)
|
|
|
|
`(,(N 'Pattern-DCompound)
|
|
|
|
(,(N 'DCompound-dict)
|
|
|
|
(,(N 'CDict))
|
|
|
|
(hash ,@(append* (for/list [((k p) (in-hash entries))]
|
|
|
|
(define s (pat-pattern p))
|
|
|
|
(if (equal? s discard) `() `(',k ,s)))))))]
|
2021-06-02 10:37:36 +00:00
|
|
|
[other (error 'pat-pattern "Unimplemented: ~v" other)]))
|
|
|
|
|
2021-06-03 20:42:01 +00:00
|
|
|
(define (top-pat top-name name p ty k-nonrecord)
|
2021-06-03 13:58:48 +00:00
|
|
|
(let ((fields (match ty
|
|
|
|
[(ty-unit) '()]
|
2021-06-08 16:01:27 +00:00
|
|
|
[(ty-record fields) fields]
|
2021-06-03 13:58:48 +00:00
|
|
|
[_ #f])))
|
|
|
|
(if (not fields)
|
|
|
|
(k-nonrecord)
|
2021-06-10 14:21:30 +00:00
|
|
|
`(define-preserves-pattern
|
|
|
|
,top-name
|
|
|
|
,(format-symbol "parse-~a" top-name)
|
|
|
|
(,name ,@(map escape (map ty-field-name fields)))
|
2021-06-03 13:58:48 +00:00
|
|
|
(quasisyntax ,(pat-pattern p))
|
|
|
|
(append ,@(for/list [(f (in-list fields))]
|
2021-06-08 16:01:27 +00:00
|
|
|
`(map ,(final-atom-destructurer (unwrap (ty-field-pattern f)))
|
|
|
|
(analyse-pattern-bindings
|
|
|
|
(syntax ,(escape (ty-field-name f)))))))))))
|
2021-06-02 10:37:36 +00:00
|
|
|
|
2021-06-03 13:58:48 +00:00
|
|
|
(match def
|
|
|
|
[(Definition-or p0 p1 pN)
|
2021-06-10 14:21:30 +00:00
|
|
|
`(begin
|
|
|
|
,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
|
|
|
|
(alt-ty (in-list (map ty-variant-type (ty-union-variants (definition-ty def)))))]
|
|
|
|
(match-define (NamedAlternative variant-label-str pattern) named-alt)
|
|
|
|
(define full-name (format-symbol "~a-~a" name variant-label-str))
|
|
|
|
(top-pat name full-name pattern alt-ty
|
|
|
|
(lambda ()
|
|
|
|
`(define-preserves-pattern
|
|
|
|
,name
|
|
|
|
,(format-symbol "parse-~a" name)
|
|
|
|
(,full-name value)
|
|
|
|
(analyse-pattern #'value)
|
|
|
|
(map ,(final-atom-destructurer (unwrap pattern))
|
|
|
|
(analyse-pattern-bindings (syntax value))))))))]
|
2021-06-03 13:58:48 +00:00
|
|
|
[(? Definition-and?)
|
|
|
|
`(begin)]
|
|
|
|
[(Definition-Pattern p)
|
2021-06-03 20:42:01 +00:00
|
|
|
(top-pat name name p (definition-ty def) (lambda () `(begin)))]))
|
2021-06-02 10:37:36 +00:00
|
|
|
|
|
|
|
(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)))
|