159 lines
6.7 KiB
Racket
159 lines
6.7 KiB
Racket
#lang racket/base
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2021-2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
(provide schema-compiler-plugin
|
|
schema-compiler-plugin-mode)
|
|
|
|
(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-mode (make-parameter 'normal))
|
|
|
|
(define (schema-compiler-plugin method)
|
|
(match method
|
|
['schema schema-compiler-plugin/schema]))
|
|
|
|
(define (schema-compiler-plugin/schema schema options)
|
|
(match-define (schema-compiler-options _name
|
|
lookup-module-path
|
|
paths) options)
|
|
(define ds-path
|
|
(match (schema-compiler-plugin-mode)
|
|
['normal 'syndicate/schemas/dataspacePatterns]
|
|
['meta (lookup-module-path '(dataspacePatterns))]))
|
|
(define meta?
|
|
(match (schema-compiler-plugin-mode)
|
|
['normal #f]
|
|
['meta (equal? ds-path (schema-translation-paths-relative-output-path paths))]))
|
|
|
|
(define (N sym)
|
|
(if meta?
|
|
sym
|
|
(format-symbol ":pat:~a" sym)))
|
|
|
|
(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-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]))
|
|
|
|
(define (def-pattern name def)
|
|
(define discard `(,(N 'Pattern-discard)))
|
|
|
|
(define (pat-pattern p)
|
|
(match (unwrap p)
|
|
[(Binding name (SimplePattern-embedded _)) `(:pattern ,(escape name) embedded)]
|
|
[(Binding name p) `(:pattern ,(escape name))]
|
|
[(SimplePattern-any) discard]
|
|
[(SimplePattern-atom _atomKind) discard]
|
|
[(SimplePattern-embedded _interface) discard]
|
|
[(SimplePattern-lit value)
|
|
(if (eq? value '...)
|
|
`(,(N 'Pattern-lit) (quote (... ...)))
|
|
`(,(N 'Pattern-lit) ',value))]
|
|
[(SimplePattern-seqof pat) discard]
|
|
[(SimplePattern-setof pat) discard]
|
|
[(SimplePattern-dictof key-pat value-pat) discard]
|
|
[(SimplePattern-Ref (Ref (ModulePath 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))
|
|
`(:pat:rec ',label (list ,@(map pat-pattern field-pats)))]
|
|
[((Binding name _) (CompoundPattern-tuple field-pats))
|
|
`(:pat:rec ,(escape name) (list ,@(map pat-pattern field-pats)))]
|
|
[(_ _)
|
|
`#,(raise-syntax-error ',name "Record schema cannot be used as a pattern")])]
|
|
[(CompoundPattern-tuple pats)
|
|
`(:pat:arr (list ,@(map pat-pattern pats)))]
|
|
[(CompoundPattern-tuplePrefix fixed-pats variable-pat)
|
|
`#,(raise-syntax-error ',name "Variable-length array cannot be used as a pattern")]
|
|
[(CompoundPattern-dict (DictionaryEntries entries))
|
|
`(:pat:dict (hash ,@(append* (for/list [((k p) (in-hash entries))]
|
|
(define s (pat-pattern p))
|
|
`(',k ,s)))))]
|
|
[other (error 'pat-pattern "Unimplemented: ~v" other)]))
|
|
|
|
(define (top-pat top-name name p ty k-nonrecord)
|
|
(let ((fields (match ty
|
|
[(ty-unit) '()]
|
|
[(ty-record fields) fields]
|
|
[_ #f])))
|
|
(if (not fields)
|
|
(k-nonrecord)
|
|
`(define-preserves-pattern
|
|
,top-name
|
|
,(format-symbol "parse-~a" top-name)
|
|
(,name ,@(map escape (map ty-field-name fields)))
|
|
(quasisyntax ,(pat-pattern p))
|
|
(append ,@(for/list [(f (in-list fields))]
|
|
`(map ,(final-atom-destructurer (unwrap (ty-field-pattern f)))
|
|
(analyse-pattern-bindings
|
|
(syntax ,(escape (ty-field-name f)))))))))))
|
|
|
|
(match def
|
|
[(Definition-or p0 p1 pN)
|
|
`(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))))))))]
|
|
[(? Definition-and?)
|
|
`(begin)]
|
|
[(Definition-Pattern p)
|
|
(top-pat name name p (definition-ty def) (lambda () `(begin)))]))
|
|
|
|
(define exprs
|
|
`((require (prefix-in :pat: ,ds-path))
|
|
(require (prefix-in :pat: syndicate/smart-pattern))
|
|
(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)))
|