type abstractions
This commit is contained in:
parent
80ef12ef4d
commit
c9563cd0a2
|
@ -194,7 +194,10 @@
|
||||||
(define-container-type AssertionSet #:arity = 1)
|
(define-container-type AssertionSet #:arity = 1)
|
||||||
(define-container-type Patch #:arity = 2)
|
(define-container-type Patch #:arity = 2)
|
||||||
|
|
||||||
|
;; functions and type abstractions
|
||||||
|
(define-binding-type ∀)
|
||||||
(define-type-constructor → #:arity > 0)
|
(define-type-constructor → #:arity > 0)
|
||||||
|
|
||||||
;; for describing the RHS
|
;; for describing the RHS
|
||||||
;; a value and a description of the effects
|
;; a value and a description of the effects
|
||||||
(define-type-constructor Computation #:arity = 4)
|
(define-type-constructor Computation #:arity = 4)
|
||||||
|
@ -230,11 +233,11 @@
|
||||||
(define-type-alias ⊥ (U*))
|
(define-type-alias ⊥ (U*))
|
||||||
|
|
||||||
(define-for-syntax (prune+sort tys)
|
(define-for-syntax (prune+sort tys)
|
||||||
(stx-sort
|
(stx-sort
|
||||||
(filter-maximal
|
(filter-maximal
|
||||||
(stx->list tys)
|
(stx->list tys)
|
||||||
typecheck?)))
|
typecheck?)))
|
||||||
|
|
||||||
(define-syntax (U stx)
|
(define-syntax (U stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ . tys)
|
[(_ . tys)
|
||||||
|
@ -245,6 +248,22 @@
|
||||||
(stx-car #'tys-)
|
(stx-car #'tys-)
|
||||||
(syntax/loc stx (U* . tys-)))]))
|
(syntax/loc stx (U* . tys-)))]))
|
||||||
|
|
||||||
|
(define-simple-macro (→fn ty-in ... ty-out)
|
||||||
|
(→ ty-in ... (Computation (Value ty-out)
|
||||||
|
(Endpoints)
|
||||||
|
(Roles)
|
||||||
|
(Spawns))))
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
(define-syntax ~→fn
|
||||||
|
(pattern-expander
|
||||||
|
(syntax-parser
|
||||||
|
[(_ ty-in:id ... ty-out)
|
||||||
|
#'(~→ ty-in ... (~Computation (~Value ty-out)
|
||||||
|
(~Endpoints)
|
||||||
|
(~Roles)
|
||||||
|
(~Spawns)))]))))
|
||||||
|
|
||||||
;; for looking at the "effects"
|
;; for looking at the "effects"
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
(define-syntax ~effs
|
(define-syntax ~effs
|
||||||
|
@ -694,6 +713,15 @@
|
||||||
(<: #'τ-out1 #'τ-out2))]
|
(<: #'τ-out1 #'τ-out2))]
|
||||||
[(~Discard _)
|
[(~Discard _)
|
||||||
#t]
|
#t]
|
||||||
|
[(X:id Y:id)
|
||||||
|
#;(printf "id case!\n")
|
||||||
|
(free-identifier=? #'X #'Y)]
|
||||||
|
[((~∀ (X:id ...) τ1) (~∀ (Y:id ...) τ2))
|
||||||
|
#:when (stx-length=? #'(X ...) #'(Y ...))
|
||||||
|
#:with τ2-X/Y (substs #'(X ...) #'(Y ...) #'τ2)
|
||||||
|
#;(printf "in ∀!\n")
|
||||||
|
#;(printf "τ2-X/Y = ~a\n" #'τ2-X/Y)
|
||||||
|
(<: #'τ1 #'τ2-X/Y)]
|
||||||
[((~Base τ1:id) (~Base τ2:id))
|
[((~Base τ1:id) (~Base τ2:id))
|
||||||
(free-identifier=? #'τ1 #'τ2)]
|
(free-identifier=? #'τ1 #'τ2)]
|
||||||
[((~Any/bvs τ-cons1 () τ1 ...) (~Any/bvs τ-cons2 () τ2 ...))
|
[((~Any/bvs τ-cons1 () τ1 ...) (~Any/bvs τ-cons2 () τ2 ...))
|
||||||
|
@ -715,7 +743,9 @@
|
||||||
[(== irrelevant)
|
[(== irrelevant)
|
||||||
#t]))]
|
#t]))]
|
||||||
;; TODO: clauses for Roles, and so on
|
;; TODO: clauses for Roles, and so on
|
||||||
[_ #f]))
|
[_
|
||||||
|
#;(printf "ids? ~a, ~a\n" (identifier? t1) (identifier? t2))
|
||||||
|
#f]))
|
||||||
|
|
||||||
;; shortcuts for mapping
|
;; shortcuts for mapping
|
||||||
(define ((<:l l) r)
|
(define ((<:l l) r)
|
||||||
|
@ -1093,6 +1123,27 @@
|
||||||
(Endpoints τ-ep ...)
|
(Endpoints τ-ep ...)
|
||||||
(Roles τ-f ...)
|
(Roles τ-f ...)
|
||||||
(Spawns τ-s ...))))])
|
(Spawns τ-s ...))))])
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; Type Abstraction
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define-typed-syntax (Λ (tv:id ...) e) ≫
|
||||||
|
[([tv ≫ tv- :: #%type] ...) () ⊢ e ≫ e- ⇒ τ]
|
||||||
|
--------
|
||||||
|
;; can't use internal mk-∀- constructor here
|
||||||
|
;; - will cause the bound-id=? quirk to show up
|
||||||
|
;; (when subsequent tyvar refs are expanded with `type` stx class)
|
||||||
|
;; - requires converting type= and subst to use free-id=?
|
||||||
|
;; (which is less performant)
|
||||||
|
[⊢ e- ⇒ (∀ (tv- ...) τ)])
|
||||||
|
|
||||||
|
(define-typed-syntax inst
|
||||||
|
[(_ e τ:type ...) ≫
|
||||||
|
[⊢ e ≫ e- ⇒ (~∀ tvs τ_body)]
|
||||||
|
#:fail-unless (pure? #'e-) "expression must be pure"
|
||||||
|
--------
|
||||||
|
[⊢ e- ⇒ #,(substs #'(τ.norm ...) #'tvs #'τ_body)]]
|
||||||
|
[(_ e) ≫ --- [≻ e]])
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Sequencing & Definitions
|
;; Sequencing & Definitions
|
||||||
|
|
|
@ -8,11 +8,12 @@
|
||||||
;; Start dataspace programs
|
;; Start dataspace programs
|
||||||
run-ground-dataspace
|
run-ground-dataspace
|
||||||
;; Types
|
;; Types
|
||||||
Int Bool String Tuple Bind Discard → ByteString Symbol
|
Int Bool String Tuple Bind Discard → ∀ ByteString Symbol
|
||||||
Role Reacts Shares Know ¬Know Message OnDataflow Stop OnStart OnStop
|
Role Reacts Shares Know ¬Know Message OnDataflow Stop OnStart OnStop
|
||||||
FacetName Field ★/t
|
FacetName Field ★/t
|
||||||
Observe Inbound Outbound Actor U
|
Observe Inbound Outbound Actor U
|
||||||
Computation Value Endpoints Roles Spawns
|
Computation Value Endpoints Roles Spawns
|
||||||
|
→fn
|
||||||
;; Statements
|
;; Statements
|
||||||
let let* if spawn dataspace start-facet set! begin stop begin/dataflow #;unsafe-do
|
let let* if spawn dataspace start-facet set! begin stop begin/dataflow #;unsafe-do
|
||||||
when unless send! define
|
when unless send! define
|
||||||
|
@ -22,6 +23,7 @@
|
||||||
assert on field
|
assert on field
|
||||||
;; expressions
|
;; expressions
|
||||||
tuple select lambda ref observe inbound outbound
|
tuple select lambda ref observe inbound outbound
|
||||||
|
Λ inst
|
||||||
;; making types
|
;; making types
|
||||||
define-type-alias
|
define-type-alias
|
||||||
define-constructor define-constructor*
|
define-constructor define-constructor*
|
||||||
|
|
|
@ -0,0 +1,36 @@
|
||||||
|
#lang typed/syndicate/roles
|
||||||
|
|
||||||
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; Type Abstraction
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define id
|
||||||
|
(Λ [τ]
|
||||||
|
(lambda ([x : τ])
|
||||||
|
x)))
|
||||||
|
|
||||||
|
(check-type id : (∀ (τ) (→fn τ τ)))
|
||||||
|
|
||||||
|
(check-type ((inst id Int) 1)
|
||||||
|
: Int
|
||||||
|
⇒ 1)
|
||||||
|
(check-type ((inst id String) "hello")
|
||||||
|
: String
|
||||||
|
⇒ "hello")
|
||||||
|
|
||||||
|
(define poly-first
|
||||||
|
(Λ [τ σ]
|
||||||
|
(lambda ([t : (Tuple τ σ)])
|
||||||
|
(select 0 t))))
|
||||||
|
|
||||||
|
(check-type poly-first : (∀ (A B) (→fn (Tuple A B) A)))
|
||||||
|
|
||||||
|
(check-type ((inst poly-first Int String) (tuple 13 "XD"))
|
||||||
|
: Int
|
||||||
|
⇒ 13)
|
||||||
|
|
||||||
|
(check-type ((inst poly-first Int String) (tuple 13 "XD"))
|
||||||
|
: Int
|
||||||
|
⇒ 13)
|
Loading…
Reference in New Issue