131 lines
4.5 KiB
Racket
131 lines
4.5 KiB
Racket
#lang turnstile
|
|
|
|
(provide (all-defined-out)
|
|
(for-syntax (all-defined-out)))
|
|
|
|
(require "base-types.rkt")
|
|
(require "effects.rkt")
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; User Defined Types, aka Constructors
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(begin-for-syntax
|
|
(define-splicing-syntax-class type-constructor-decl
|
|
(pattern (~seq #:type-constructor TypeCons:id))
|
|
(pattern (~seq) #:attr TypeCons #f))
|
|
|
|
(struct user-ctor (typed-ctor untyped-ctor)
|
|
#:property prop:procedure
|
|
(lambda (v stx)
|
|
(define transformer (user-ctor-typed-ctor v))
|
|
(syntax-parse stx
|
|
[(_ e ...)
|
|
#`(#,transformer e ...)]))))
|
|
|
|
(define-syntax (define-constructor* stx)
|
|
(syntax-parse stx
|
|
#:datum-literals (:)
|
|
[(_ (Cons:id : TyCons:id slot:id ...) clause ...)
|
|
#'(define-constructor (Cons slot ...)
|
|
#:type-constructor TyCons
|
|
clause ...)]))
|
|
|
|
(define-syntax (define-constructor stx)
|
|
(syntax-parse stx
|
|
[(_ (Cons:id slot:id ...)
|
|
ty-cons:type-constructor-decl
|
|
(~seq #:with
|
|
Alias AliasBody) ...)
|
|
#:with TypeCons (or (attribute ty-cons.TypeCons) (format-id stx "~a/t" (syntax-e #'Cons)))
|
|
#:with MakeTypeCons (format-id #'TypeCons "make-~a" #'TypeCons)
|
|
#:with GetTypeParams (format-id #'TypeCons "get-~a-type-params" #'TypeCons)
|
|
#:with TypeConsExpander (format-id #'TypeCons "~~~a" #'TypeCons)
|
|
#:with TypeConsExtraInfo (format-id #'TypeCons "~a-extra-info" #'TypeCons)
|
|
#:with (StructName Cons- type-tag) (generate-temporaries #'(Cons Cons Cons))
|
|
(define arity (stx-length #'(slot ...)))
|
|
#`(begin-
|
|
(struct- StructName (slot ...) #:reflection-name 'Cons #:transparent)
|
|
(define-syntax (TypeConsExtraInfo stx)
|
|
(syntax-parse stx
|
|
[(_ X (... ...)) #'('type-tag 'MakeTypeCons 'GetTypeParams)]))
|
|
(define-type-constructor TypeCons
|
|
#:arity = #,arity
|
|
#:extra-info 'TypeConsExtraInfo)
|
|
(define-syntax (MakeTypeCons stx)
|
|
(syntax-parse stx
|
|
[(_ t (... ...))
|
|
#:fail-unless (= #,arity (stx-length #'(t (... ...)))) "arity mismatch"
|
|
#'(TypeCons t (... ...))]))
|
|
(define-syntax (GetTypeParams stx)
|
|
(syntax-parse stx
|
|
[(_ (TypeConsExpander t (... ...)))
|
|
#'(t (... ...))]))
|
|
(define-syntax Cons
|
|
(user-ctor #'Cons- #'StructName))
|
|
(define-typed-syntax (Cons- e (... ...)) ≫
|
|
#:fail-unless (= #,arity (stx-length #'(e (... ...)))) "arity mismatch"
|
|
[⊢ e ≫ e- (⇒ : τ)] (... ...)
|
|
#:fail-unless (all-pure? #'(e- (... ...))) "expressions must be pure"
|
|
----------------------
|
|
[⊢ (#%app- StructName e- (... ...)) (⇒ : (TypeCons τ (... ...)))])
|
|
(define-type-alias Alias AliasBody) ...)]))
|
|
|
|
(begin-for-syntax
|
|
(define-syntax ~constructor-extra-info
|
|
(pattern-expander
|
|
(syntax-parser
|
|
[(_ tag mk get)
|
|
#'(_ (_ tag) (_ mk) (_ get))])))
|
|
|
|
(define-syntax ~constructor-type
|
|
(pattern-expander
|
|
(syntax-parser
|
|
[(_ tag . rst)
|
|
#'(~and it
|
|
(~fail #:unless (user-defined-type? #'it))
|
|
(~parse tag (get-type-tag #'it))
|
|
(~Any _ . rst))])))
|
|
|
|
(define-syntax ~constructor-exp
|
|
(pattern-expander
|
|
(syntax-parser
|
|
[(_ cons . rst)
|
|
#'(~and (cons . rst)
|
|
(~fail #:unless (ctor-id? #'cons)))])))
|
|
|
|
(define (inspect t)
|
|
(syntax-parse t
|
|
[(~constructor-type tag t ...)
|
|
(list (syntax-e #'tag) (stx-map type->str #'(t ...)))]))
|
|
|
|
(define (tags-equal? t1 t2)
|
|
(equal? (syntax-e t1) (syntax-e t2)))
|
|
|
|
(define (user-defined-type? t)
|
|
(get-extra-info ((current-type-eval) t)))
|
|
|
|
(define (get-type-tag t)
|
|
(syntax-parse (get-extra-info t)
|
|
[(~constructor-extra-info tag _ _)
|
|
(syntax-e #'tag)]))
|
|
|
|
(define (get-type-args t)
|
|
(syntax-parse (get-extra-info t)
|
|
[(~constructor-extra-info _ _ get)
|
|
(define f (syntax-local-value #'get))
|
|
(syntax->list (f #`(get #,t)))]))
|
|
|
|
(define (make-cons-type t args)
|
|
(syntax-parse (get-extra-info t)
|
|
[(~constructor-extra-info _ mk _)
|
|
(define f (syntax-local-value #'mk))
|
|
((current-type-eval) (f #`(mk #,@args)))]))
|
|
|
|
(define (ctor-id? stx)
|
|
(and (identifier? stx)
|
|
(user-ctor? (syntax-local-value stx (const #f)))))
|
|
|
|
(define (untyped-ctor stx)
|
|
(user-ctor-untyped-ctor (syntax-local-value stx (const #f)))))
|