print types different
This commit is contained in:
parent
5d922fe030
commit
d9da970742
|
@ -295,6 +295,13 @@
|
||||||
(Spawns))))
|
(Spawns))))
|
||||||
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
|
(define-syntax ~Base
|
||||||
|
(pattern-expander
|
||||||
|
(syntax-parser
|
||||||
|
[(_ nm:id)
|
||||||
|
#'((~literal #%plain-app) nm)])))
|
||||||
|
|
||||||
|
|
||||||
(define-syntax ~→fn
|
(define-syntax ~→fn
|
||||||
(pattern-expander
|
(pattern-expander
|
||||||
(syntax-parser
|
(syntax-parser
|
||||||
|
@ -789,36 +796,44 @@
|
||||||
(reassemble-type #'τ-cons subitems)]
|
(reassemble-type #'τ-cons subitems)]
|
||||||
[_ t]))
|
[_ t]))
|
||||||
|
|
||||||
;; Copied and modified from turnstile
|
;; Type -> String
|
||||||
;; try to handle type variables for Stop references and polymorphic effects
|
|
||||||
;; better
|
|
||||||
(define-for-syntax (type->strX ty)
|
(define-for-syntax (type->strX ty)
|
||||||
(define τ (get-orig ty))
|
;; Identifier -> String
|
||||||
(cond
|
;; this won't work for any names with numbers in them :\
|
||||||
[(and (row-variable? τ)
|
(define (un-gensym x)
|
||||||
(stx-list? ty))
|
(define GENSYMED #px"^(\\D*)\\d*$")
|
||||||
(string-join (stx-map type->strX ty)
|
(second (regexp-match GENSYMED (symbol->string (syntax-e x)))))
|
||||||
#:before-first "("
|
;; (Listof String) -> String
|
||||||
#:after-last ")")]
|
(define (paren-join xs)
|
||||||
[(identifier? τ)
|
(string-join xs
|
||||||
(symbol->string (syntax->datum τ))]
|
#:before-first "("
|
||||||
[(stx-list? τ) (string-join (stx-map type->strX τ)
|
#:after-last ")"))
|
||||||
#:before-first "("
|
(syntax-parse ty
|
||||||
#:after-last ")")]
|
[X:id
|
||||||
[else (format "~s" (syntax->datum τ))]))
|
(un-gensym #'X)]
|
||||||
|
[(~U* τ ...)
|
||||||
|
(paren-join (cons "U" (stx-map type->strX #'(τ ...))))]
|
||||||
|
[(~Base x)
|
||||||
|
(un-gensym #'x)]
|
||||||
|
[(~Any/bvs τ-cons (X ...) τ ...)
|
||||||
|
(define ctor (un-gensym #'τ-cons))
|
||||||
|
(define body (stx-map type->strX #'(τ ...)))
|
||||||
|
(define desc
|
||||||
|
(cond
|
||||||
|
[(empty? (syntax->list #'(X ...)))
|
||||||
|
(list* ctor body)]
|
||||||
|
[else
|
||||||
|
(define vars
|
||||||
|
(paren-join (stx-map type->strX #'(X ...))))
|
||||||
|
(list* ctor vars body)]))
|
||||||
|
(paren-join desc)]))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Subtyping and Judgments on Types
|
;; Subtyping and Judgments on Types
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
(define-syntax ~Base
|
(define trace-sub? (make-parameter #f))
|
||||||
(pattern-expander
|
|
||||||
(syntax-parser
|
|
||||||
[(_ nm:id)
|
|
||||||
#'((~literal #%plain-app) nm)])))
|
|
||||||
|
|
||||||
(define trace-sub? (make-parameter #f))
|
|
||||||
|
|
||||||
;; Type Type -> Bool
|
;; Type Type -> Bool
|
||||||
;; subtyping
|
;; subtyping
|
||||||
|
|
|
@ -53,7 +53,7 @@
|
||||||
(all-from-out "maybe.rkt")
|
(all-from-out "maybe.rkt")
|
||||||
(all-from-out "either.rkt")
|
(all-from-out "either.rkt")
|
||||||
;; DEBUG and utilities
|
;; DEBUG and utilities
|
||||||
print-type print-role
|
print-type print-role role-strings
|
||||||
;; Extensions
|
;; Extensions
|
||||||
match cond
|
match cond
|
||||||
;; require & provides
|
;; require & provides
|
||||||
|
@ -470,6 +470,14 @@
|
||||||
----------------------------------
|
----------------------------------
|
||||||
[⊢ e- (⇒ : τ) (⇒ ν-ep (eps ...)) (⇒ ν-f (fs ...)) (⇒ ν-s (ss ...))])
|
[⊢ e- (⇒ : τ) (⇒ ν-ep (eps ...)) (⇒ ν-f (fs ...)) (⇒ ν-s (ss ...))])
|
||||||
|
|
||||||
|
;; this is mainly for testing
|
||||||
|
(define-typed-syntax (role-strings e) ≫
|
||||||
|
[⊢ e ≫ e- (⇒ : τ) (⇒ ν-f (~effs fs ...))]
|
||||||
|
#:with (s ...) (for/list ([r (in-syntax #'(fs ...))])
|
||||||
|
(type->strX r))
|
||||||
|
----------------------------------------
|
||||||
|
[⊢ (#%app- list- (#%datum- . s) ...) (⇒ : (List String))])
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Tests
|
;; Tests
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
|
@ -0,0 +1,21 @@
|
||||||
|
#lang typed/syndicate/roles
|
||||||
|
|
||||||
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
;; make sure that we can look at the type of the facet without the ρ in it
|
||||||
|
(check-type
|
||||||
|
(role-strings
|
||||||
|
(start-facet x
|
||||||
|
(define (push-results)
|
||||||
|
(cond
|
||||||
|
[(zero? 0)
|
||||||
|
(start-facet done (assert #t))]
|
||||||
|
[else
|
||||||
|
#f]))
|
||||||
|
(define (∀ (ρ) (perform-task [k : (proc -> ★/t #:roles (ρ))]))
|
||||||
|
(start-facet perform
|
||||||
|
(on start (stop perform (k)))))
|
||||||
|
(on start (call/inst perform-task push-results))))
|
||||||
|
: (List String)
|
||||||
|
-> (list
|
||||||
|
"(Role (x) (Reacts OnStart (Role (perform) (Reacts OnStart (Stop perform (Branch (Effs (Role (done) (Shares Bool))) (Effs)))))))"))
|
Loading…
Reference in New Issue