preserves/implementations/racket/preserves/preserves-schema/type.rkt

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) ":"))))