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

Further work on typed syntax

Browse Source
This commit is contained in:
Georges Dupéron 2017-01-11 03:58:37 +01:00
parent 3b59681010
commit dc1561e595
4 changed files with 68 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
comments/syntax-properties-typed.rkt
View File

@ -12,14 +12,14 @@
(define-type First-Comments (define-type First-Comments
(Rec R (Pairof (U #f (Pairof (Syntaxof 'saved-props+srcloc) (Rec R (Pairof (U #f (Pairof (Syntaxof 'saved-props+srcloc)
R)) R))
(Listof (Syntaxof Any))))) (Listof ISyntax))))
(define-type Comments-After (define-type Comments-After
(Listof (Syntaxof Any))) (Listof ISyntax))
(: with-first-comments (∀ (A) (→ (Syntaxof A) (: with-first-comments (∀ (A) (→ ISyntax
(U #f First-Comments) (U #f First-Comments)
(Syntaxof A)))) ISyntax)))
(define (with-first-comments e c) (define (with-first-comments e c)
(if (or (not c) (and (= (length c) 1) (not (first c)))) (if (or (not c) (and (= (length c) 1) (not (first c))))

82
comments/typed-syntax-convert.rkt
View File

@ -132,85 +132,3 @@
[(unmodified) (list e)] [(unmodified) (list e)]
[(modified) (list e*)] [(modified) (list e*)]
[(#f) #f]))) [(#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])))

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

@ -15,6 +15,8 @@
ISyntaxOf-E ISyntaxOf-E
ISyntax ISyntax
ISyntax-E ISyntax-E
ISyntax/Not
ISyntax/Not-E
(struct-out NonSyntax) (struct-out NonSyntax)
;(struct-out NonSexp) ; already exported in typed-syntax-convert.rkt ;(struct-out NonSexp) ; already exported in typed-syntax-convert.rkt
NonSyntaxOf NonSyntaxOf
@ -65,47 +67,57 @@
(struct (A) NonSyntax ([value : A]) #:type-name NonSyntaxOf) (struct (A) NonSyntax ([value : A]) #:type-name NonSyntaxOf)
(struct (A) NonSexp ([value : A]) #:type-name NonSexpOf) (struct (A) NonSexp ([value : A]) #:type-name NonSexpOf)
(define-type ISyntax (ISyntaxOf (NonSyntaxOf Any) (NonSexpOf Any))) (define-type ISyntax/Not (ISyntaxOf (NonSyntaxOf Any) (NonSexpOf Any)))
(define-type ISyntax-E (ISyntaxOf-E (NonSyntaxOf Any) (NonSexpOf Any))) (define-type ISyntax/Not-E (ISyntaxOf-E (NonSyntaxOf Any) (NonSexpOf Any)))
(: syntax->isyntax (→ (Syntaxof Any) (define-type ISyntax (ISyntaxOf Nothing Nothing))
(Values ISyntax (define-type ISyntax-E (ISyntaxOf-E Nothing Nothing))
(U 'modified 'unmodified))))
(define (syntax->isyntax stx) (: 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 e (syntax-e stx))
(define-values (e* status) (any->isyntax-e e)) (define-values (e* status) (any->isyntax-e e nstx nsexp))
(case status (case status
[(unmodified) [(unmodified)
(values (unsafe-cast e ISyntax) 'unmodified)] (values (unsafe-cast e (ISyntaxOf A B)) 'unmodified)]
[(modified) [(modified)
(values (datum->syntax* stx e* stx stx) 'modified)] (values (datum->syntax* stx e* stx stx) 'modified)]
#;[(#f) #;[(#f)
(values #f #f)])) (values #f #f)]))
(: any->isyntax (→ Any (: any->isyntax (∀ (A B) (→ Any
(Values ISyntax (→ Any (Values A (U 'modified 'unmodified #;#f)))
(U 'modified 'unmodified)))) (→ Any (Values B (U 'modified 'unmodified #;#f)))
(define (any->isyntax e) (Values (ISyntaxOf A B)
(U 'modified 'unmodified #;#f)))))
(define (any->isyntax e nstx nsexp)
(if (syntax? e) (if (syntax? e)
(syntax->isyntax e) (syntax->isyntax e nstx nsexp)
(values (NonSyntax e) 'modified))) (nstx e)))
(: listof-any->listof-isyntax (→ (Listof Any) (: listof-any->listof-isyntax
(Pairof (Listof ISyntax) (∀ (A B) (→ (Listof Any)
(U 'modified 'unmodified)))) (→ Any (Values A (U 'modified 'unmodified #;#f)))
(define (listof-any->listof-isyntax e) (→ 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* (define e+status*
(map (λ ([eᵢ : Any]) (map (λ ([eᵢ : Any])
(let-values ([(eᵢ* status) (any->isyntax eᵢ)]) (let-values ([(eᵢ* status) (any->isyntax eᵢ nstx nsexp)])
(cons eᵢ* status))) (cons eᵢ* status)))
e)) e))
(define e* (map car e+status*)) (define e* (map car e+status*))
(define status* (map cdr e+status*)) (define status* (map cdr e+status*))
(cond (cond
[(andmap (curry eq? 'unmodified) status*) [(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*) #;[(ormap (curry eq? #f) status*)
(cons #f #f)] (cons #f #f)]
[else [else
(cons e* 'modified)])) (cons e* 'modified)]))
@ -128,20 +140,23 @@
(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 (→ (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)))))
(Values (Pairof ISyntax (→ Any (Values A (U 'modified 'unmodified #;#f)))
(Rec L (U ISyntax (→ Any (Values B (U 'modified 'unmodified #;#f)))
Null (Values (Pairof (ISyntaxOf A B)
(Pairof ISyntax L)))) (Rec L (U (ISyntaxOf A B)
(U 'unmodified 'modified)))) Null
(define (handle-pair e) (Pairof (ISyntaxOf A B)
L))))
(U 'unmodified 'modified)))))
(define (handle-pair e nstx nsexp)
(let-values ([(car* status-car) (let-values ([(car* status-car)
(any->isyntax (car e))]) (any->isyntax (car e) nstx nsexp)])
(cond (cond
[(pair? (cdr e)) [(pair? (cdr e))
(let-values ([(cdr* status-cdr) (let-values ([(cdr* status-cdr)
(handle-pair (cdr e))]) (handle-pair (cdr e) nstx nsexp)])
(cond (cond
#;[(and (eq? status-car 'unmodified) #;[(and (eq? status-car 'unmodified)
(eq? status-cdr 'unmodified)) (eq? status-cdr 'unmodified))
@ -165,7 +180,7 @@
(values (cons car* (cdr e)) 'modified)])] (values (cons car* (cdr e)) 'modified)])]
[else [else
(let-values ([(cdr* status-cdr) (let-values ([(cdr* status-cdr)
(any->isyntax (cdr e))]) (any->isyntax (cdr e) nstx nsexp)])
(cond (cond
#;[(and (eq? status-car 'unmodified) #;[(and (eq? status-car 'unmodified)
(eq? status-cdr 'unmodified)) (eq? status-cdr 'unmodified))
@ -198,10 +213,12 @@
[else [else
(values (cons car* cdr*) 'modified)])) (values (cons car* cdr*) 'modified)]))
(: any->isyntax-e (→ Any (: any->isyntax-e (∀ (A B) (→ Any
(Values ISyntax-E (→ Any (Values A (U 'modified 'unmodified #;#f)))
(U 'modified 'unmodified)))) (→ Any (Values B (U 'modified 'unmodified #;#f)))
(define (any->isyntax-e e) (Values (ISyntaxOf-E A B)
(U 'modified 'unmodified #;#f)))))
(define (any->isyntax-e e nstx nsexp)
(cond (cond
[(boolean? e) (values e 'unmodified)] [(boolean? e) (values e 'unmodified)]
[(char? e) (values e 'unmodified)] [(char? e) (values e 'unmodified)]
@ -212,7 +229,7 @@
(values e 'unmodified) (values e 'unmodified)
(values (string->immutable-string e) 'modified))] (values (string->immutable-string e) 'modified))]
[(symbol? e) (values e 'unmodified)] [(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 (case status
[(unmodified) [(unmodified)
;(if (immutable? e) ;(if (immutable? e)
@ -223,17 +240,19 @@
(values (box-immutable u*) 'modified)] (values (box-immutable u*) 'modified)]
#;[(#f) #;[(#f)
(values #f #f)]))] (values #f #f)]))]
[(pair? e) (handle-pair e)] [(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))]) (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 ISyntax-E) 'unmodified) (values (unsafe-cast e (ISyntaxOf-E A B))
(values (apply vector-immutable vs*) 'modified))] 'unmodified)
(values (apply vector-immutable vs*)
'modified))]
[(modified) [(modified)
(values (apply vector-immutable vs*) 'modified)] (values (apply vector-immutable vs*) 'modified)]
#;[(#f) #;[(#f)
(values #f #f)]))] (values #f #f)]))]
[else [else
(values (NonSexp e) 'modified)])) (nsexp e)]))

4
comments/typed-syntax.rkt
View File

@ -6,8 +6,8 @@
CoreSexp CoreSexp
ISyntaxOf ISyntaxOf
ISyntaxOf-E ISyntaxOf-E
ISyntax ISyntax/Not
ISyntax-E ISyntax/Not-E
NonSyntaxOf NonSyntaxOf
NonSexpOf NonSexpOf
any->isyntax ;; TODO: make wrappers for these, which discard the second value any->isyntax ;; TODO: make wrappers for these, which discard the second value