Further work on typed syntax
This commit is contained in:
Georges Dupéron
parent
3b59681010
commit
dc1561e595
|
|
@ -12,14 +12,14 @@
|
|||
(define-type First-Comments
|
||||
(Rec R (Pairof (U #f (Pairof (Syntaxof 'saved-props+srcloc)
|
||||
R))
|
||||
(Listof (Syntaxof Any)))))
|
||||
(Listof ISyntax))))
|
||||
|
||||
(define-type Comments-After
|
||||
(Listof (Syntaxof Any)))
|
||||
(Listof ISyntax))
|
||||
|
||||
(: with-first-comments (∀ (A) (→ (Syntaxof A)
|
||||
(: with-first-comments (∀ (A) (→ ISyntax
|
||||
(U #f First-Comments)
|
||||
(Syntaxof A))))
|
||||
ISyntax)))
|
||||
(define (with-first-comments e c)
|
||||
|
||||
(if (or (not c) (and (= (length c) 1) (not (first c))))
|
||||
|
|
|
|||
|
|
@ -132,85 +132,3 @@
|
|||
[(unmodified) (list e)]
|
||||
[(modified) (list e*)]
|
||||
[(#f) #f])))
|
||||
|
||||
;; Syntax:
|
||||
|
||||
(struct (A) NonSyntax ([value : A]) #:type-name NonSyntaxOf)
|
||||
(define-type (SyntaxU A)
|
||||
(Syntaxof (SexpStx A)))
|
||||
(define-type (SexpStx A)
|
||||
(Rec sexp (U Boolean
|
||||
Char
|
||||
Complex
|
||||
Keyword
|
||||
Null
|
||||
String
|
||||
Symbol
|
||||
(Boxof sexp)
|
||||
(Pairof sexp sexp)
|
||||
(Vectorof sexp)
|
||||
(Syntaxof sexp)
|
||||
A)))
|
||||
|
||||
(: syntax-wrapper (∀ (A) (→ (non-sexp-handler (U A (SyntaxU A)))
|
||||
(non-sexp-handler (U A (SyntaxU A))))))
|
||||
(define (syntax-wrapper nested-wrapper)
|
||||
(: recur (→ Any
|
||||
(Values (U (Sexpof (U A (SyntaxU A))) #f)
|
||||
(U 'unmodified 'modified #f))))
|
||||
(define (recur e)
|
||||
(cond
|
||||
[(syntax? e)
|
||||
(let-values ([(e* status) (try-any->isexp* (syntax-e e) recur)])
|
||||
(case status
|
||||
[(unmodified) (values (ann (unsafe-cast e (U (SyntaxU A) #f))
|
||||
(U (SyntaxU A) #f))'unmodified)]
|
||||
[(modified) (values (datum->syntax* e e* e e) 'modified)]
|
||||
[(#f) (values #f #f)]))]
|
||||
[else (nested-wrapper e)]))
|
||||
recur)
|
||||
|
||||
(: any->isexpstx+non-syntax (→ Any (Sexpof (U (NonSyntaxOf Any) (SyntaxU (NonSyntaxOf Any))))))
|
||||
(define (any->isexpstx+non-syntax e)
|
||||
(let*-values ([(e* status)
|
||||
((inst try-any->isexp* (U (NonSyntaxOf Any) (SyntaxU (NonSyntaxOf Any))))
|
||||
e
|
||||
(syntax-wrapper
|
||||
(λ (non-syntax-e)
|
||||
(values (NonSyntax non-syntax-e)
|
||||
'modified))))])
|
||||
(case status
|
||||
[(unmodified) (unsafe-cast e (SyntaxU (NonSyntaxOf Any)))]
|
||||
[(modified) e*]
|
||||
[(#f)
|
||||
(error
|
||||
(string-append "Got #f from try->any-isexp* using non-sexp which does"
|
||||
" not return #f."))])))
|
||||
|
||||
;; TODO: this duplicates parts of any->isexpstx+non-syntax and syntax-wrapper.
|
||||
(: syntax->isyntax+non-syntax (→ Syntax (SyntaxU (NonSyntaxOf Any))))
|
||||
(define (syntax->isyntax+non-syntax e)
|
||||
(let-values ([(e* status) (try-any->isexp* (syntax-e e)
|
||||
(syntax-wrapper
|
||||
(λ (non-syntax-e)
|
||||
(values (NonSyntax non-syntax-e)
|
||||
'modified))))])
|
||||
(case status
|
||||
[(unmodified) (unsafe-cast e (SyntaxU (NonSyntaxOf Any)))]
|
||||
[(modified) (datum->syntax* e e* e e)]
|
||||
[(#f)
|
||||
(error (string-append "Got #f from try->any-isexp* using non-sexp which"
|
||||
" does not return #f."))])))
|
||||
|
||||
|
||||
;(: try-any->isyntax (→ Any (U (List Any) #f)))
|
||||
#;(define (try-any->isyntax e)
|
||||
(let*-values ([(e* status) (try-any->isexp*
|
||||
e
|
||||
(λ (non-sexp-e)
|
||||
(values #f #f)))])
|
||||
(case status
|
||||
[(unmodified) (list e)]
|
||||
[(modified) (list e*)]
|
||||
[(#f) #f])))
|
||||
|
||||
|
|
|
|||
|
|
@ -15,6 +15,8 @@
|
|||
ISyntaxOf-E
|
||||
ISyntax
|
||||
ISyntax-E
|
||||
ISyntax/Not
|
||||
ISyntax/Not-E
|
||||
(struct-out NonSyntax)
|
||||
;(struct-out NonSexp) ; already exported in typed-syntax-convert.rkt
|
||||
NonSyntaxOf
|
||||
|
|
@ -65,45 +67,55 @@
|
|||
(struct (A) NonSyntax ([value : A]) #:type-name NonSyntaxOf)
|
||||
(struct (A) NonSexp ([value : A]) #:type-name NonSexpOf)
|
||||
|
||||
(define-type ISyntax (ISyntaxOf (NonSyntaxOf Any) (NonSexpOf Any)))
|
||||
(define-type ISyntax-E (ISyntaxOf-E (NonSyntaxOf Any) (NonSexpOf Any)))
|
||||
(define-type ISyntax/Not (ISyntaxOf (NonSyntaxOf Any) (NonSexpOf Any)))
|
||||
(define-type ISyntax/Not-E (ISyntaxOf-E (NonSyntaxOf Any) (NonSexpOf Any)))
|
||||
|
||||
(: syntax->isyntax (→ (Syntaxof Any)
|
||||
(Values ISyntax
|
||||
(U 'modified 'unmodified))))
|
||||
(define (syntax->isyntax stx)
|
||||
(define-type ISyntax (ISyntaxOf Nothing Nothing))
|
||||
(define-type ISyntax-E (ISyntaxOf-E Nothing Nothing))
|
||||
|
||||
(: syntax->isyntax (∀ (A B) (→ (Syntaxof Any)
|
||||
(→ Any (Values A (U 'modified 'unmodified #;#f)))
|
||||
(→ Any (Values B (U 'modified 'unmodified #;#f)))
|
||||
(Values (ISyntaxOf A B) ;; TODO: change to (SyntaxOf (ISnyntaxOf-E …))
|
||||
(U 'modified 'unmodified #;#f)))))
|
||||
(define (syntax->isyntax stx nstx nsexp)
|
||||
(define e (syntax-e stx))
|
||||
(define-values (e* status) (any->isyntax-e e))
|
||||
(define-values (e* status) (any->isyntax-e e nstx nsexp))
|
||||
(case status
|
||||
[(unmodified)
|
||||
(values (unsafe-cast e ISyntax) 'unmodified)]
|
||||
(values (unsafe-cast e (ISyntaxOf A B)) 'unmodified)]
|
||||
[(modified)
|
||||
(values (datum->syntax* stx e* stx stx) 'modified)]
|
||||
#;[(#f)
|
||||
(values #f #f)]))
|
||||
|
||||
(: any->isyntax (→ Any
|
||||
(Values ISyntax
|
||||
(U 'modified 'unmodified))))
|
||||
(define (any->isyntax e)
|
||||
(: any->isyntax (∀ (A B) (→ Any
|
||||
(→ Any (Values A (U 'modified 'unmodified #;#f)))
|
||||
(→ Any (Values B (U 'modified 'unmodified #;#f)))
|
||||
(Values (ISyntaxOf A B)
|
||||
(U 'modified 'unmodified #;#f)))))
|
||||
(define (any->isyntax e nstx nsexp)
|
||||
(if (syntax? e)
|
||||
(syntax->isyntax e)
|
||||
(values (NonSyntax e) 'modified)))
|
||||
(syntax->isyntax e nstx nsexp)
|
||||
(nstx e)))
|
||||
|
||||
(: listof-any->listof-isyntax (→ (Listof Any)
|
||||
(Pairof (Listof ISyntax)
|
||||
(U 'modified 'unmodified))))
|
||||
(define (listof-any->listof-isyntax e)
|
||||
(: listof-any->listof-isyntax
|
||||
(∀ (A B) (→ (Listof Any)
|
||||
(→ Any (Values A (U 'modified 'unmodified #;#f)))
|
||||
(→ Any (Values B (U 'modified 'unmodified #;#f)))
|
||||
(Pairof (Listof (ISyntaxOf A B))
|
||||
(U 'modified 'unmodified #;#f)))))
|
||||
(define (listof-any->listof-isyntax e nstx nsexp)
|
||||
(define e+status*
|
||||
(map (λ ([eᵢ : Any])
|
||||
(let-values ([(eᵢ* status) (any->isyntax eᵢ)])
|
||||
(let-values ([(eᵢ* status) (any->isyntax eᵢ nstx nsexp)])
|
||||
(cons eᵢ* status)))
|
||||
e))
|
||||
(define e* (map car e+status*))
|
||||
(define status* (map cdr e+status*))
|
||||
(cond
|
||||
[(andmap (curry eq? 'unmodified) status*)
|
||||
(cons (unsafe-cast e (Listof ISyntax)) 'unmodified)]
|
||||
(cons (unsafe-cast e (Listof (ISyntaxOf A B))) 'unmodified)]
|
||||
#;[(ormap (curry eq? #f) status*)
|
||||
(cons #f #f)]
|
||||
[else
|
||||
|
|
@ -128,20 +140,23 @@
|
|||
(Rec L (U Syntax-E
|
||||
(Pairof Syntax-E L))))
|
||||
(U 'unmodified 'modified)))))
|
||||
(: handle-pair (→ (U (Pairof Any (Listof Any))
|
||||
(: handle-pair (∀ (A B) (→ (U (Pairof Any (Listof Any))
|
||||
(Pairof Any (Rec L (U Any (Pairof Any L)))))
|
||||
(Values (Pairof ISyntax
|
||||
(Rec L (U ISyntax
|
||||
(→ Any (Values A (U 'modified 'unmodified #;#f)))
|
||||
(→ Any (Values B (U 'modified 'unmodified #;#f)))
|
||||
(Values (Pairof (ISyntaxOf A B)
|
||||
(Rec L (U (ISyntaxOf A B)
|
||||
Null
|
||||
(Pairof ISyntax L))))
|
||||
(U 'unmodified 'modified))))
|
||||
(define (handle-pair e)
|
||||
(Pairof (ISyntaxOf A B)
|
||||
L))))
|
||||
(U 'unmodified 'modified)))))
|
||||
(define (handle-pair e nstx nsexp)
|
||||
(let-values ([(car* status-car)
|
||||
(any->isyntax (car e))])
|
||||
(any->isyntax (car e) nstx nsexp)])
|
||||
(cond
|
||||
[(pair? (cdr e))
|
||||
(let-values ([(cdr* status-cdr)
|
||||
(handle-pair (cdr e))])
|
||||
(handle-pair (cdr e) nstx nsexp)])
|
||||
(cond
|
||||
#;[(and (eq? status-car 'unmodified)
|
||||
(eq? status-cdr 'unmodified))
|
||||
|
|
@ -165,7 +180,7 @@
|
|||
(values (cons car* (cdr e)) 'modified)])]
|
||||
[else
|
||||
(let-values ([(cdr* status-cdr)
|
||||
(any->isyntax (cdr e))])
|
||||
(any->isyntax (cdr e) nstx nsexp)])
|
||||
(cond
|
||||
#;[(and (eq? status-car 'unmodified)
|
||||
(eq? status-cdr 'unmodified))
|
||||
|
|
@ -198,10 +213,12 @@
|
|||
[else
|
||||
(values (cons car* cdr*) 'modified)]))
|
||||
|
||||
(: any->isyntax-e (→ Any
|
||||
(Values ISyntax-E
|
||||
(U 'modified 'unmodified))))
|
||||
(define (any->isyntax-e e)
|
||||
(: any->isyntax-e (∀ (A B) (→ Any
|
||||
(→ Any (Values A (U 'modified 'unmodified #;#f)))
|
||||
(→ Any (Values B (U 'modified 'unmodified #;#f)))
|
||||
(Values (ISyntaxOf-E A B)
|
||||
(U 'modified 'unmodified #;#f)))))
|
||||
(define (any->isyntax-e e nstx nsexp)
|
||||
(cond
|
||||
[(boolean? e) (values e 'unmodified)]
|
||||
[(char? e) (values e 'unmodified)]
|
||||
|
|
@ -212,7 +229,7 @@
|
|||
(values e 'unmodified)
|
||||
(values (string->immutable-string e) 'modified))]
|
||||
[(symbol? e) (values e 'unmodified)]
|
||||
[(box? e) (let-values ([(u* status) (any->isyntax (unbox e))])
|
||||
[(box? e) (let-values ([(u* status) (any->isyntax (unbox e) nstx nsexp)])
|
||||
(case status
|
||||
[(unmodified)
|
||||
;(if (immutable? e)
|
||||
|
|
@ -223,17 +240,19 @@
|
|||
(values (box-immutable u*) 'modified)]
|
||||
#;[(#f)
|
||||
(values #f #f)]))]
|
||||
[(pair? e) (handle-pair e)]
|
||||
[(pair? e) (handle-pair e nstx nsexp)]
|
||||
[(vector? e) (match-let ([(cons vs* status)
|
||||
(listof-any->listof-isyntax (vector->list e))])
|
||||
(listof-any->listof-isyntax (vector->list e) nstx nsexp)])
|
||||
(case status
|
||||
[(unmodified)
|
||||
(if (immutable? e)
|
||||
(values (unsafe-cast e ISyntax-E) 'unmodified)
|
||||
(values (apply vector-immutable vs*) 'modified))]
|
||||
(values (unsafe-cast e (ISyntaxOf-E A B))
|
||||
'unmodified)
|
||||
(values (apply vector-immutable vs*)
|
||||
'modified))]
|
||||
[(modified)
|
||||
(values (apply vector-immutable vs*) 'modified)]
|
||||
#;[(#f)
|
||||
(values #f #f)]))]
|
||||
[else
|
||||
(values (NonSexp e) 'modified)]))
|
||||
(nsexp e)]))
|
||||
|
|
@ -6,8 +6,8 @@
|
|||
CoreSexp
|
||||
ISyntaxOf
|
||||
ISyntaxOf-E
|
||||
ISyntax
|
||||
ISyntax-E
|
||||
ISyntax/Not
|
||||
ISyntax/Not-E
|
||||
NonSyntaxOf
|
||||
NonSexpOf
|
||||
any->isyntax ;; TODO: make wrappers for these, which discard the second value
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user