suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Made any->isyntax and similar functions configurable, to choose how non-syntax and non-sexp cases should be handled

Browse Source
This commit is contained in:
Georges Dupéron 2017-01-11 03:59:28 +01:00
parent dc1561e595
commit 503044660b
1 changed files with 128 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

263
comments/typed-syntax-convert2.rkt
View File

@ -73,27 +73,29 @@
(define-type ISyntax (ISyntaxOf Nothing Nothing)) (define-type ISyntax (ISyntaxOf Nothing Nothing))
(define-type ISyntax-E (ISyntaxOf-E Nothing Nothing)) (define-type ISyntax-E (ISyntaxOf-E Nothing Nothing))
(define-type (Result A) (U (Pairof A (U 'modified 'unmodified))
(Pairof #f #f)))
(define Result#f (cons #f #f))
(: syntax->isyntax (∀ (A B) (→ (Syntaxof Any) (: syntax->isyntax (∀ (A B) (→ (Syntaxof Any)
(→ Any (Values A (U 'modified 'unmodified #;#f))) (→ Any (Result A))
(→ Any (Values B (U 'modified 'unmodified #;#f))) (→ Any (Result B))
(Values (ISyntaxOf A B) ;; TODO: change to (SyntaxOf (ISnyntaxOf-E …)) (U (Result (ISyntaxOf A B)))))) ;; TODO: change to (SyntaxOf (ISnyntaxOf-E …))
(U 'modified 'unmodified #;#f)))))
(define (syntax->isyntax stx nstx nsexp) (define (syntax->isyntax stx nstx nsexp)
(define e (syntax-e stx)) (define e (syntax-e stx))
(define-values (e* status) (any->isyntax-e e nstx nsexp)) (match-define (cons e* status) (any->isyntax-e e nstx nsexp))
(case status (case status
[(unmodified) [(unmodified)
(values (unsafe-cast e (ISyntaxOf A B)) 'unmodified)] (cons (unsafe-cast e (ISyntaxOf A B)) 'unmodified)]
[(modified) [(modified)
(values (datum->syntax* stx e* stx stx) 'modified)] (cons (datum->syntax* stx e* stx stx) 'modified)]
#;[(#f) [(#f)
(values #f #f)])) Result#f]))
(: any->isyntax (∀ (A B) (→ Any (: any->isyntax (∀ (A B) (→ Any
(→ Any (Values A (U 'modified 'unmodified #;#f))) (→ Any (Result A))
(→ Any (Values B (U 'modified 'unmodified #;#f))) (→ Any (Result B))
(Values (ISyntaxOf A B) (Result (ISyntaxOf A B)))))
(U 'modified 'unmodified #;#f)))))
(define (any->isyntax e nstx nsexp) (define (any->isyntax e nstx nsexp)
(if (syntax? e) (if (syntax? e)
(syntax->isyntax e nstx nsexp) (syntax->isyntax e nstx nsexp)
@ -101,158 +103,149 @@
(: listof-any->listof-isyntax (: listof-any->listof-isyntax
(∀ (A B) (→ (Listof Any) (∀ (A B) (→ (Listof Any)
(→ Any (Values A (U 'modified 'unmodified #;#f))) (→ Any (Result A))
(→ Any (Values B (U 'modified 'unmodified #;#f))) (→ Any (Result B))
(Pairof (Listof (ISyntaxOf A B)) (Result (Listof (ISyntaxOf A B))))))
(U 'modified 'unmodified #;#f)))))
(define (listof-any->listof-isyntax e nstx nsexp) (define (listof-any->listof-isyntax e nstx nsexp)
(define e+status* (define e*+status
(map (λ ([eᵢ : Any]) (foldr (λ ([eᵢ : Any] [acc : (Result (Listof (ISyntaxOf A B)))])
(let-values ([(eᵢ* status) (any->isyntax eᵢ nstx nsexp)]) (match-let ([(cons eᵢ* status) (any->isyntax eᵢ nstx nsexp)])
(cons eᵢ* status))) (cond
[(and (eq? status 'unmodified)
(eq? (cdr acc) 'unmodified))
(cons (cons eᵢ* (car acc)) 'unmodified)]
[(or (eq? status #f)
(eq? (cdr acc) #f))
Result#f]
[else
(cons (cons eᵢ* (car acc)) 'modified)])))
(cons '() 'unmodified)
e)) e))
(define e* (map car e+status*)) (define e* (car e*+status))
(define status* (map cdr e+status*)) (define status (cdr e*+status))
(cond (case status
[(andmap (curry eq? 'unmodified) status*) [(unmodified) (cons (unsafe-cast e (Listof (ISyntaxOf A B))) 'unmodified)]
(cons (unsafe-cast e (Listof (ISyntaxOf A B))) 'unmodified)] [(modified) (cons e* 'modified)]
#;[(ormap (curry eq? #f) status*) [(#f) Result#f]))
(cons #f #f)]
[else
(cons e* 'modified)]))
#;(: handle-pair (case→ (→ (Listof Any) #;(: handle-pair (case→ (→ (Listof Any)
(Values (Listof Syntax-E) (Values (Listof Syntax-E)
(U 'unmodified 'modified))) (U 'unmodified 'modified)))
(→ (Pairof Any (Rec L (U Any (Pairof Any L)))) (→ (Pairof Any (Rec L (U Any (Pairof Any L))))
(Values (Pairof Syntax-E (Values (Pairof Syntax-E
(Rec L (U Syntax-E (Rec L (U Syntax-E
(Pairof Syntax-E L)))) (Pairof Syntax-E L))))
(U 'unmodified 'modified))) (U 'unmodified 'modified)))
(→ Any (→ Any
(Values ISyntax (Values ISyntax
(U 'unmodified 'modified))))) (U 'unmodified 'modified)))))
#;(: handle-pair (case→ (→ (Pairof Any (Listof Any)) #;(: handle-pair (case→ (→ (Pairof Any (Listof Any))
(Values (Listof Syntax-E) (Values (Listof Syntax-E)
(U 'unmodified 'modified))) (U 'unmodified 'modified)))
(→ (Pairof Any (Rec L (U Any (Pairof Any L)))) (→ (Pairof Any (Rec L (U Any (Pairof Any L))))
(Values (Pairof Syntax-E (Values (Pairof Syntax-E
(Rec L (U Syntax-E (Rec L (U Syntax-E
(Pairof Syntax-E L)))) (Pairof Syntax-E L))))
(U 'unmodified 'modified))))) (U 'unmodified 'modified)))))
(: handle-pair (∀ (A B) (→ (U (Pairof Any (Listof Any)) (: handle-pair (∀ (A B) (→ (U (Pairof Any (Listof Any))
(Pairof Any (Rec L (U Any (Pairof Any L))))) (Pairof Any (Rec L (U Any (Pairof Any L)))))
(→ Any (Values A (U 'modified 'unmodified #;#f))) (→ Any (Result A))
(→ Any (Values B (U 'modified 'unmodified #;#f))) (→ Any (Result B))
(Values (Pairof (ISyntaxOf A B) (Result (Pairof (ISyntaxOf A B)
(Rec L (U (ISyntaxOf A B) (Rec L (U (ISyntaxOf A B)
Null Null
(Pairof (ISyntaxOf A B) (Pairof (ISyntaxOf A B)
L)))) L))))))))
(U 'unmodified 'modified)))))
(define (handle-pair e nstx nsexp) (define (handle-pair e nstx nsexp)
(let-values ([(car* status-car) (define car*+status (any->isyntax (car e) nstx nsexp))
(any->isyntax (car e) nstx nsexp)]) (define car* (car car*+status))
(cond (define status-car (cdr car*+status))
[(pair? (cdr e)) (cond
(let-values ([(cdr* status-cdr) [(pair? (cdr e))
(handle-pair (cdr e) nstx nsexp)]) (match-let ([(cons cdr* status-cdr)
(cond (handle-pair (cdr e) nstx nsexp)])
#;[(and (eq? status-car 'unmodified)
(eq? status-cdr 'unmodified))
(values (unsafe-cast e (Pairof ISyntax
(Rec L (U ISyntax
Null
(Pairof ISyntax L)))))
'unmodified)]
#;[(or (eq? status-car #f)
(eq? status-cdr #f))
(values #f #f)]
[else
(values (cons car* cdr*) 'modified)]))]
[(null? (cdr e))
(cond (cond
#;[(eq? status-car 'unmodified) #;[(and (eq? status-car 'unmodified)
(values (unsafe-cast e (Pairof ISyntax Null)) 'unmodified)] (eq? status-cdr 'unmodified))
#;[(eq? status-car #f) (cons (unsafe-cast e (Pairof ISyntax
(values #f #f)] (Rec L (U ISyntax
Null
(Pairof ISyntax L)))))
'unmodified)]
[(or (eq? status-car #f)
(eq? status-cdr #f))
Result#f]
[else [else
(values (cons car* (cdr e)) 'modified)])] (cons (cons car* cdr*) 'modified)]))]
[else [(null? (cdr e))
(let-values ([(cdr* status-cdr) (cond
(any->isyntax (cdr e) nstx nsexp)]) #;[(eq? status-car 'unmodified)
(cond (cons (unsafe-cast e (Pairof ISyntax Null)) 'unmodified)]
#;[(and (eq? status-car 'unmodified) [(eq? status-car #f)
(eq? status-cdr 'unmodified)) Result#f]
(values (unsafe-cast e (Pairof ISyntax [else
(Rec L (U ISyntax (cons (ann (cons car* (cdr e))
Null (Pairof (ISyntaxOf A B)
(Pairof ISyntax L))))) (Rec L (U (ISyntaxOf A B)
'unmodified)] Null
#;[(or (eq? status-car #f) (Pairof (ISyntaxOf A B)
(eq? status-cdr #f)) L)))))
(values #f #f)] 'modified)])]
[else [else
(values (cons car* cdr*) 'modified)]))]) (match-let ([(cons cdr* status-cdr) (any->isyntax (cdr e) nstx nsexp)])
#;[(null? e) (cond
(values e 'unmodified)] #;[(and (eq? status-car 'unmodified)
#;[else (eq? status-cdr 'unmodified))
(any->isyntax e)])) (cons (unsafe-cast e (Pairof ISyntax
(Rec L (U ISyntax
#;(let*-values ([(car* status-car) Null
(any->isyntax (car e))] (Pairof ISyntax L)))))
[(cdr* status-cdr) 'unmodified)]
(any->isyntax (cdr e))]) [(or (eq? status-car #f)
(cond (eq? status-cdr #f))
#;[(and (eq? status-car 'unmodified) Result#f]
(eq? status-cdr 'unmodified)) [else
(values (unsafe-cast e (ISyntax-E A)) 'unmodified)] (cons (cons car* cdr*) 'modified)]))]))
#;[(or (eq? status-car #f)
(eq? status-cdr #f))
(values #f #f)]
[else
(values (cons car* cdr*) 'modified)]))
(: any->isyntax-e (∀ (A B) (→ Any (: any->isyntax-e (∀ (A B) (→ Any
(→ Any (Values A (U 'modified 'unmodified #;#f))) (→ Any (Result A))
(→ Any (Values B (U 'modified 'unmodified #;#f))) (→ Any (Result B))
(Values (ISyntaxOf-E A B) (Result (ISyntaxOf-E A B)))))
(U 'modified 'unmodified #;#f)))))
(define (any->isyntax-e e nstx nsexp) (define (any->isyntax-e e nstx nsexp)
(cond (cond
[(boolean? e) (values e 'unmodified)] [(boolean? e) (cons e 'unmodified)]
[(char? e) (values e 'unmodified)] [(char? e) (cons e 'unmodified)]
[(number? e) (values e 'unmodified)] [(number? e) (cons e 'unmodified)]
[(keyword? e) (values e 'unmodified)] [(keyword? e) (cons e 'unmodified)]
[(null? e) (values e 'unmodified)] [(null? e) (cons e 'unmodified)]
[(string? e) (if (immutable? e) [(string? e) (if (immutable? e)
(values e 'unmodified) (cons e 'unmodified)
(values (string->immutable-string e) 'modified))] (cons (string->immutable-string e) 'modified))]
[(symbol? e) (values e 'unmodified)] [(symbol? e) (cons e 'unmodified)]
[(box? e) (let-values ([(u* status) (any->isyntax (unbox e) nstx nsexp)]) [(box? e) (match-let ([(cons u* status) (any->isyntax (unbox e) nstx nsexp)])
(case status (case status
[(unmodified) [(unmodified)
;(if (immutable? e) ;(if (immutable? e)
;(values (unsafe-cast e (Sexpof A)) 'unmodified) ;(values (unsafe-cast e (Sexpof A)) 'unmodified)
(values (box-immutable u*) 'modified);) (cons (box-immutable u*) 'modified);)
] ]
[(modified) [(modified)
(values (box-immutable u*) 'modified)] (cons (box-immutable u*) 'modified)]
#;[(#f) [(#f)
(values #f #f)]))] Result#f]))]
[(pair? e) (handle-pair e nstx nsexp)] [(pair? e) (handle-pair e nstx nsexp)]
[(vector? e) (match-let ([(cons vs* status) [(vector? e) (match-let ([(cons vs* status)
(listof-any->listof-isyntax (vector->list e) nstx nsexp)]) (listof-any->listof-isyntax (vector->list e) nstx nsexp)])
(case status (case status
[(unmodified) [(unmodified)
(if (immutable? e) (if (immutable? e)
(values (unsafe-cast e (ISyntaxOf-E A B)) (cons (unsafe-cast e (ISyntaxOf-E A B))
'unmodified) 'unmodified)
(values (apply vector-immutable vs*) (cons (apply vector-immutable vs*)
'modified))] 'modified))]
[(modified) [(modified)
(values (apply vector-immutable vs*) 'modified)] (cons (apply vector-immutable vs*) 'modified)]
#;[(#f) [(#f)
(values #f #f)]))] Result#f]))]
[else [else
(nsexp e)])) (nsexp e)]))