diff --git a/comments/syntax-properties-typed.rkt b/comments/syntax-properties-typed.rkt index 77763e1b..611ec942 100644 --- a/comments/syntax-properties-typed.rkt +++ b/comments/syntax-properties-typed.rkt @@ -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)))) diff --git a/comments/typed-syntax-convert.rkt b/comments/typed-syntax-convert.rkt index 830704cd..df9f59f9 100644 --- a/comments/typed-syntax-convert.rkt +++ b/comments/typed-syntax-convert.rkt @@ -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]))) - diff --git a/comments/typed-syntax-convert2.rkt b/comments/typed-syntax-convert2.rkt index b8d02daa..c46cb762 100644 --- a/comments/typed-syntax-convert2.rkt +++ b/comments/typed-syntax-convert2.rkt @@ -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,47 +67,57 @@ (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)])) + (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)] + (cons #f #f)] [else (cons e* 'modified)])) @@ -128,20 +140,23 @@ (Rec L (U Syntax-E (Pairof Syntax-E L)))) (U 'unmodified 'modified))))) -(: handle-pair (→ (U (Pairof Any (Listof Any)) - (Pairof Any (Rec L (U Any (Pairof Any L))))) - (Values (Pairof ISyntax - (Rec L (U ISyntax - Null - (Pairof ISyntax L)))) - (U 'unmodified 'modified)))) -(define (handle-pair e) +(: handle-pair (∀ (A B) (→ (U (Pairof Any (Listof Any)) + (Pairof Any (Rec L (U Any (Pairof Any L))))) + (→ 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 (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)])) \ No newline at end of file + (nsexp e)])) \ No newline at end of file diff --git a/comments/typed-syntax.rkt b/comments/typed-syntax.rkt index 31fe96ee..a0a8d42f 100644 --- a/comments/typed-syntax.rkt +++ b/comments/typed-syntax.rkt @@ -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