134 lines
5.7 KiB
Racket
134 lines
5.7 KiB
Racket
#lang racket/base
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2021 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/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))]))
|
|
|
|
(define (N sym)
|
|
(if meta?
|
|
sym
|
|
(format-symbol ":pat:~a" sym)))
|
|
|
|
(define (def-pattern name def)
|
|
(define discard `(,(N 'Pattern-DDiscard) (,(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 'Pattern-DLit) (,(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 'Pattern-DCompound)
|
|
(,(N 'DCompound-rec)
|
|
(,(N 'CRec) ',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 'Pattern-DCompound)
|
|
(,(N 'DCompound-arr)
|
|
(,(N 'CArr) ,(length pats))
|
|
(hasheqv ,@(append* (for/list [(i (in-naturals))
|
|
(p (in-list pats))]
|
|
(define s (pat-pattern p))
|
|
(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)))))))]
|
|
[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) (map escape (map ty-field-name fields))]
|
|
[_ #f])))
|
|
(if (not fields)
|
|
(k-nonrecord)
|
|
`(define-preserves-pattern ,top-name (,name ,@fields)
|
|
(quasisyntax ,(pat-pattern p))
|
|
(append ,@(for/list [(f (in-list fields))]
|
|
`(analyse-pattern-bindings (syntax ,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 (,full-name value)
|
|
(analyse-pattern #'value)
|
|
(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 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)))
|