102 lines
3.4 KiB
Racket
102 lines
3.4 KiB
Racket
#lang racket/base
|
|
|
|
(provide (struct-out ty-union)
|
|
(struct-out ty-unit)
|
|
(struct-out ty-value)
|
|
(struct-out ty-record)
|
|
(struct-out ty-array)
|
|
(struct-out ty-set)
|
|
(struct-out ty-dictionary)
|
|
|
|
(struct-out ty-variant)
|
|
(struct-out ty-field)
|
|
|
|
definition-ty
|
|
unwrap
|
|
escape
|
|
module-path-prefix)
|
|
|
|
(require preserves/record)
|
|
(require preserves/order)
|
|
(require racket/match)
|
|
(require (only-in racket/syntax format-symbol))
|
|
(require (only-in racket/string string-join))
|
|
|
|
(require "gen/schema.rkt")
|
|
|
|
(struct ty-union (variants) #:transparent)
|
|
(struct ty-unit () #:transparent)
|
|
(struct ty-value () #:transparent)
|
|
(struct ty-record (fields) #:transparent)
|
|
(struct ty-array (type) #:transparent)
|
|
(struct ty-set (type) #:transparent)
|
|
(struct ty-dictionary (key-type value-type) #:transparent)
|
|
|
|
(struct ty-variant (name type pattern) #:transparent)
|
|
(struct ty-field (name type pattern) #:transparent)
|
|
|
|
(define (definition-ty d)
|
|
(match d
|
|
[(Definition-or p0 p1 pN)
|
|
(ty-union (map (match-lambda [(NamedAlternative variant-label-str pattern)
|
|
(ty-variant (string->symbol variant-label-str)
|
|
(pattern-ty pattern)
|
|
pattern)])
|
|
(list* p0 p1 pN)))]
|
|
[(Definition-and p0 p1 pN) (product-ty (list* p0 p1 pN))]
|
|
[(Definition-Pattern pattern) (pattern-ty pattern)]))
|
|
|
|
(define (product-ty named-pats)
|
|
(match (gather-fields* named-pats '())
|
|
['() (ty-unit)]
|
|
[fields (ty-record fields)]))
|
|
|
|
(define (unwrap p)
|
|
(match p
|
|
[(Pattern-SimplePattern p) (unwrap p)]
|
|
[(Pattern-CompoundPattern p) (unwrap p)]
|
|
[(NamedPattern-named p) (unwrap p)]
|
|
[(NamedSimplePattern-named p) (unwrap p)]
|
|
[(NamedPattern-anonymous p) (unwrap p)]
|
|
[(NamedSimplePattern-anonymous p) (unwrap p)]
|
|
[_ p]))
|
|
|
|
(define (gather-fields* named-pats acc)
|
|
(foldr gather-fields acc named-pats))
|
|
|
|
(define (gather-fields named-pat acc)
|
|
(match (unwrap named-pat)
|
|
[(Binding n p)
|
|
(match (pattern-ty p)
|
|
[(ty-unit) acc]
|
|
[ty (cons (ty-field n ty p) acc)])]
|
|
[(? SimplePattern?) acc]
|
|
[(CompoundPattern-rec label-named-pat fields-named-pat)
|
|
(gather-fields label-named-pat (gather-fields fields-named-pat acc))]
|
|
[(CompoundPattern-tuple named-pats)
|
|
(gather-fields* named-pats acc)]
|
|
[(CompoundPattern-tuplePrefix fixed-named-pats variable-named-pat)
|
|
(gather-fields* fixed-named-pats (gather-fields variable-named-pat acc))]
|
|
[(CompoundPattern-dict (DictionaryEntries entries))
|
|
(gather-fields* (map cdr (sorted-dict-entries entries)) acc)]))
|
|
|
|
(define (pattern-ty p)
|
|
(match (unwrap p)
|
|
[(SimplePattern-any) (ty-value)]
|
|
[(SimplePattern-atom _atomKind) (ty-value)]
|
|
[(SimplePattern-embedded _interface) (ty-value)]
|
|
[(SimplePattern-lit _value) (ty-unit)]
|
|
[(SimplePattern-seqof pat) (ty-array (pattern-ty pat))]
|
|
[(SimplePattern-setof pat) (ty-set (pattern-ty pat))]
|
|
[(SimplePattern-dictof kp vp) (ty-dictionary (pattern-ty kp) (pattern-ty vp))]
|
|
[(SimplePattern-Ref _r) (ty-value)]
|
|
[(? CompoundPattern?) (product-ty (list p))]))
|
|
|
|
(define (escape s)
|
|
(format-symbol "?~a" s))
|
|
|
|
(define (module-path-prefix module-path)
|
|
(if (null? module-path)
|
|
'||
|
|
(format-symbol "~a:" (string-join (map symbol->string module-path) ":"))))
|