Wrote wrappers for the configurable functions any->isyntax* syntax->isyntax* any->isyntax-e*
This commit is contained in:
Georges Dupéron
parent
503044660b
commit
b79ec821d4
7
comments/maybe.rkt
Normal file
7
comments/maybe.rkt
Normal file
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
(: 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)
|
||||
(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->isyntax* (∀ (A B) (→ Any
|
||||
(→ Any (Result A))
|
||||
(→ Any (Result B))
|
||||
(Result (ISyntaxOf A B)))))
|
||||
(define (any->isyntax e nstx nsexp)
|
||||
(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))
|
||||
|
|
@ -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->isyntax-e* (∀ (A B) (→ Any
|
||||
(→ Any (Result A))
|
||||
(→ Any (Result B))
|
||||
(Result (ISyntaxOf-E A B)))))
|
||||
(define (any->isyntax-e e nstx nsexp)
|
||||
(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)
|
||||
|
|
@ -249,3 +253,63 @@
|
|||
Result#f]))]
|
||||
[else
|
||||
(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))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user