From b79ec821d4b57035b4203b114a1198ab5276980b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Wed, 11 Jan 2017 20:39:39 +0100 Subject: [PATCH] Wrote wrappers for the configurable functions any->isyntax* syntax->isyntax* any->isyntax-e* --- comments/maybe.rkt | 7 ++ comments/typed-syntax-convert2.rkt | 128 +++++++++++++++++++++-------- comments/typed-syntax.rkt | 6 +- 3 files changed, 107 insertions(+), 34 deletions(-) create mode 100644 comments/maybe.rkt diff --git a/comments/maybe.rkt b/comments/maybe.rkt new file mode 100644 index 00000000..672bbeaa --- /dev/null +++ b/comments/maybe.rkt @@ -0,0 +1,7 @@ +#lang typed/racket +(provide (struct-out Some) + Maybe) + +(struct (A) Some ([v : A]) #:prefab) +(define-type (Maybe A) + (U (Some A) #f)) \ No newline at end of file diff --git a/comments/typed-syntax-convert2.rkt b/comments/typed-syntax-convert2.rkt index 1483cb44..322278d1 100644 --- a/comments/typed-syntax-convert2.rkt +++ b/comments/typed-syntax-convert2.rkt @@ -2,7 +2,8 @@ (require typed-map typed/racket/unsafe - "typed-syntax-convert.rkt") + "typed-syntax-convert.rkt" + "maybe.rkt") (unsafe-require/typed racket/base [[datum->syntax datum->syntax*] (∀ (A) (→ (Syntaxof Any) @@ -15,15 +16,18 @@ ISyntaxOf-E ISyntax ISyntax-E - ISyntax/Not - ISyntax/Not-E + ISyntax/Non + ISyntax/Non-E (struct-out NonSyntax) ;(struct-out NonSexp) ; already exported in typed-syntax-convert.rkt NonSyntaxOf NonSexpOf - any->isyntax - syntax->isyntax - any->isyntax-e) + any->isyntax+non + syntax->isyntax+non + any->isyntax-e+non + try-any->isyntax + try-syntax->isyntax + try-any->isyntax-e) (unsafe-require/typed racket/function [[identity unsafe-cast-function] (∀ (A) (→ Any A))]) @@ -67,8 +71,8 @@ (struct (A) NonSyntax ([value : A]) #:type-name NonSyntaxOf) (struct (A) NonSexp ([value : A]) #:type-name NonSexpOf) -(define-type ISyntax/Not (ISyntaxOf (NonSyntaxOf Any) (NonSexpOf Any))) -(define-type ISyntax/Not-E (ISyntaxOf-E (NonSyntaxOf Any) (NonSexpOf Any))) +(define-type ISyntax/Non (ISyntaxOf (NonSyntaxOf Any) (NonSexpOf Any))) +(define-type ISyntax/Non-E (ISyntaxOf-E (NonSyntaxOf Any) (NonSexpOf Any))) (define-type ISyntax (ISyntaxOf Nothing Nothing)) (define-type ISyntax-E (ISyntaxOf-E Nothing Nothing)) @@ -77,28 +81,28 @@ (Pairof #f #f))) (define Result#f (cons #f #f)) -(: syntax->isyntax (∀ (A B) (→ (Syntaxof Any) - (→ Any (Result A)) - (→ Any (Result B)) - (U (Result (ISyntaxOf A B)))))) ;; TODO: change to (SyntaxOf (ISnyntaxOf-E …)) -(define (syntax->isyntax stx nstx nsexp) +(: syntax->isyntax* (∀ (A B) (→ (Syntaxof Any) + (→ Any (Result A)) + (→ Any (Result B)) + (U (Result (Syntaxof (ISyntaxOf-E A B))))))) +(define (syntax->isyntax* stx nstx nsexp) (define e (syntax-e stx)) - (match-define (cons e* status) (any->isyntax-e e nstx nsexp)) + (match-define (cons e* status) (any->isyntax-e* e nstx nsexp)) (case status [(unmodified) - (cons (unsafe-cast e (ISyntaxOf A B)) 'unmodified)] + (cons (unsafe-cast e (Syntaxof (ISyntaxOf-E A B))) 'unmodified)] [(modified) (cons (datum->syntax* stx e* stx stx) 'modified)] [(#f) Result#f])) -(: any->isyntax (∀ (A B) (→ Any - (→ Any (Result A)) - (→ Any (Result B)) - (Result (ISyntaxOf A B))))) -(define (any->isyntax e nstx nsexp) +(: any->isyntax* (∀ (A B) (→ Any + (→ Any (Result A)) + (→ Any (Result B)) + (Result (ISyntaxOf A B))))) +(define (any->isyntax* e nstx nsexp) (if (syntax? e) - (syntax->isyntax e nstx nsexp) + (syntax->isyntax* e nstx nsexp) (nstx e))) (: listof-any->listof-isyntax @@ -109,7 +113,7 @@ (define (listof-any->listof-isyntax e nstx nsexp) (define e*+status (foldr (λ ([eᵢ : Any] [acc : (Result (Listof (ISyntaxOf A B)))]) - (match-let ([(cons eᵢ* status) (any->isyntax eᵢ nstx nsexp)]) + (match-let ([(cons eᵢ* status) (any->isyntax* eᵢ nstx nsexp)]) (cond [(and (eq? status 'unmodified) (eq? (cdr acc) 'unmodified)) @@ -120,7 +124,7 @@ [else (cons (cons eᵢ* (car acc)) 'modified)]))) (cons '() 'unmodified) - e)) + e)) (define e* (car e*+status)) (define status (cdr e*+status)) (case status @@ -157,7 +161,7 @@ (Pairof (ISyntaxOf A B) L)))))))) (define (handle-pair e nstx nsexp) - (define car*+status (any->isyntax (car e) nstx nsexp)) + (define car*+status (any->isyntax* (car e) nstx nsexp)) (define car* (car car*+status)) (define status-car (cdr car*+status)) (cond @@ -192,7 +196,7 @@ L))))) 'modified)])] [else - (match-let ([(cons cdr* status-cdr) (any->isyntax (cdr e) nstx nsexp)]) + (match-let ([(cons cdr* status-cdr) (any->isyntax* (cdr e) nstx nsexp)]) (cond #;[(and (eq? status-car 'unmodified) (eq? status-cdr 'unmodified)) @@ -207,11 +211,11 @@ [else (cons (cons car* cdr*) 'modified)]))])) -(: any->isyntax-e (∀ (A B) (→ Any - (→ Any (Result A)) - (→ Any (Result B)) - (Result (ISyntaxOf-E A B))))) -(define (any->isyntax-e e nstx nsexp) +(: any->isyntax-e* (∀ (A B) (→ Any + (→ Any (Result A)) + (→ Any (Result B)) + (Result (ISyntaxOf-E A B))))) +(define (any->isyntax-e* e nstx nsexp) (cond [(boolean? e) (cons e 'unmodified)] [(char? e) (cons e 'unmodified)] @@ -222,7 +226,7 @@ (cons e 'unmodified) (cons (string->immutable-string e) 'modified))] [(symbol? e) (cons e 'unmodified)] - [(box? e) (match-let ([(cons u* status) (any->isyntax (unbox e) nstx nsexp)]) + [(box? e) (match-let ([(cons u* status) (any->isyntax* (unbox e) nstx nsexp)]) (case status [(unmodified) ;(if (immutable? e) @@ -248,4 +252,64 @@ [(#f) Result#f]))] [else - (nsexp e)])) \ No newline at end of file + (nsexp e)])) + +(: any->isyntax+non (→ Any ISyntax/Non)) +(define (any->isyntax+non e) + (define e*+status + (any->isyntax* e + (λ (n) (cons (NonSyntax n) 'modified)) + (λ (n) (cons (NonSexp n) 'modified)))) + (if (cdr e*+status) + (car e*+status) + (error "Got #f from any->isyntax* with handlers not returning #f"))) + +(: syntax->isyntax+non (→ (Syntaxof Any) (Syntaxof ISyntax/Non-E))) +(define (syntax->isyntax+non stx) + (define e*+status + (syntax->isyntax* stx + (λ (n) (cons (NonSyntax n) 'modified)) + (λ (n) (cons (NonSexp n) 'modified)))) + (if (cdr e*+status) + (car e*+status) + (error "Got #f from any->isyntax* with handlers not returning #f"))) + +(: any->isyntax-e+non (→ Any ISyntax/Non-E)) +(define (any->isyntax-e+non e) + (define e*+status + (any->isyntax-e* e + (λ (n) (cons (NonSyntax n) 'modified)) + (λ (n) (cons (NonSexp n) 'modified)))) + (if (cdr e*+status) + (car e*+status) + (error "Got #f from any->isyntax* with handlers not returning #f"))) + +(: try-any->isyntax (→ Any (Maybe ISyntax))) +(define (try-any->isyntax e) + (define e*+status + ((inst any->isyntax* Nothing Nothing) e + (λ (n) Result#f) + (λ (n) Result#f))) + (if (cdr e*+status) + (Some (car e*+status)) + #f)) + +(: try-syntax->isyntax (→ (Syntaxof Any) (Maybe (Syntaxof ISyntax-E)))) +(define (try-syntax->isyntax stx) + (define e*+status + ((inst syntax->isyntax* Nothing Nothing) stx + (λ (n) Result#f) + (λ (n) Result#f))) + (if (cdr e*+status) + (Some (car e*+status)) + #f)) + +(: try-any->isyntax-e (→ Any (Maybe ISyntax-E))) +(define (try-any->isyntax-e e) + (define e*+status + ((inst any->isyntax-e* Nothing Nothing) e + (λ (n) Result#f) + (λ (n) Result#f))) + (if (cdr e*+status) + (Some (car e*+status)) + #f)) \ No newline at end of file diff --git a/comments/typed-syntax.rkt b/comments/typed-syntax.rkt index a0a8d42f..f17bae8c 100644 --- a/comments/typed-syntax.rkt +++ b/comments/typed-syntax.rkt @@ -4,10 +4,12 @@ try-any->isexp any->isexp+non-sexp CoreSexp + ISyntax + ISyntax-E ISyntaxOf ISyntaxOf-E - ISyntax/Not - ISyntax/Not-E + ISyntax/Non + ISyntax/Non-E NonSyntaxOf NonSexpOf any->isyntax ;; TODO: make wrappers for these, which discard the second value