diff --git a/comments/hide-comments-typed.rkt b/comments/hide-comments-typed.rkt
new file mode 100644
index 00000000..1e4a31f4
--- /dev/null
+++ b/comments/hide-comments-typed.rkt
@@ -0,0 +1,140 @@
+#lang typed/racket
+
+(require (rename-in syntax/parse [...+ …+])
+ syntax/stx
+ racket/match
+ racket/set
+ racket/list
+ racket/function
+ racket/vector
+ racket/contract
+ sexp-diff
+ racket/pretty
+ rackunit
+ (only-in racket/base [... …])
+ (for-syntax (rename-in racket/base [... …]))
+ tr-immutable/typed-syntax
+ "syntax-properties-typed.rkt")
+
+(provide hide-#%comment)
+
+;; ([#%comment c1] a [#%comment c2] . ([#%comment c3] b [#%comment c4]))
+;; => (aᶜ² . (bᶜ⁴)⁻ᶜ³)⁻ᶜ¹
+;; (c1 a c2 . (c3 . (c4 b c5)))
+;; => (aᶜ² . (bᶜ⁵)⁻ᶜ³⁻⁻ᶜ⁴)⁻ᶜ¹
+;; (c1 a c2 . (c3 . (c4 c5)))
+;; => (aᶜ² . ()⁻ᶜ³⁻⁻ᶜ⁴ᶜ⁵)⁻ᶜ¹
+;; (c1 a (c2) b)
+;; => (a ()⁻ᶜ² b)⁻ᶜ¹
+;; (c1 a (c2 . b) c)
+;; => (a b⁻ᶜ² c)⁻ᶜ¹
+;; (c1 a (c2 . (c3 c4)) c)
+;; => (a ()⁻ᶜ²⁻⁻ᶜ³ᶜ⁴ c)⁻ᶜ¹
+(: hide-#%comment (→ ISyntax/Non-Stx ISyntax/Non-Stx))
+(define (hide-#%comment stx)
+ (cond
+ [(pair? (syntax-e stx))
+ (hide-in-pair (syntax-e stx))]
+ [else
+ ;; TODO: recurse down vectors etc.
+ stx]))
+
+(define-type ISyntax/Non-List*
+ (Rec L (U ISyntax/Non
+ Null
+ (Pairof ISyntax/Non L))))
+
+(define pair (ann cons (∀ (A B) (→ A B (Pairof A B)))))
+
+(: hide-in-pair (→ ISyntax/Non-List*
+ ISyntax/Non-Stx))
+(define (hide-in-pair e*)
+ (let loop ([rest : ISyntax/Non-List* e*]
+ [groups : (Pairof (Listof Comment)
+ (Listof (Pairof ISyntax/Non (Listof Comment))))
+ '(())])
+ (if (pair? rest)
+ (if (comment? (car rest))
+ (loop (cdr rest)
+ (pair (pair (ann (car rest) Comment) (car groups))
+ (cdr groups)))
+ (loop (cdr rest)
+ (pair (ann '() (Listof Comment))
+ (pair (pair (car rest) (reverse (car groups)))
+ (cdr groups)))))
+ (values rest groups)))
+ (error "TODOrtfdsvc"))
+
+(define-type Comment (Syntaxof (Pairof (Syntaxof '#%comment) Any)))
+(define comment? (make-predicate Comment))
+
+
+#;(if ((make-predicate (Rec R (Pairof (Syntaxof (Pairof (Syntaxof '#%comment) Any))
+ (U Boolean
+ Char
+ Number
+ Keyword
+ Null
+ String
+ Symbol
+ BoxTop
+ VectorTop
+ R))))
+ e*)
+ (error "TODOwa" e*)
+ (error "TODOwa" e*))
+
+#|
+(: listof? (∀ (A) (→ Any (→ Any Boolean : A) Boolean : (Listof A))))
+(define (listof? l p?)
+ (pair? l
+ p?
+ (ann (λ (a)
+ (list*? a p?))
+ (→ Any Boolean : ))
+|#
+
+#;(match (syntax-e stx)
+ [(not (? pair?))
+ ;; TODO: recurse down vectors etc.
+ stx]
+ [(list* e* ... rest)
+ (error "TODO")
+ #;(syntax-parse e*
+ #:datum-literals (#%comment)
+ [({~and c₀ [#%comment . _]} …
+ {~seq {~and eᵢ {~not [#%comment . _]}}
+ {~and cᵢⱼ [#%comment . _]} …}
+ …+)
+ (define new-e* (map with-comments-after
+ (map hide-#%comment
+ (syntax->list #'(eᵢ …)))
+ (map syntax->list
+ (syntax->list #'((cᵢⱼ …) …)))))
+ (define new-rest (if (null? rest)
+ rest
+ (hide-#%comment rest)))
+ (with-first-comments
+ (datum->syntax stx (append new-e* new-rest) stx stx)
+ (cons #f (syntax->list #'(c₀ …))))]
+ [({~and c₀ [#%comment . _]} …)
+ (define new-rest (if (null? rest)
+ rest
+ (hide-#%comment rest)))
+ (with-first-comments
+ (with-comments-after
+ (datum->syntax stx new-rest stx stx)
+ (if (syntax? new-rest)
+ (syntax-property new-rest 'comments-after)
+ '()))
+ (cons (if (syntax? new-rest)
+ (cons (datum->syntax new-rest
+ 'saved-props+srcloc
+ new-rest
+ new-rest)
+ (or (syntax-property new-rest 'first-comments)
+ ;; TODO: I'm dubious about this, better typecheck
+ ;; everything…
+ (cons #f null)))
+ #f)
+ (syntax->list #'(c₀ …))))])])
\ No newline at end of file
diff --git a/comments/restore-comments-typed.rkt b/comments/restore-comments-typed.rkt
new file mode 100644
index 00000000..aab3a3fa
--- /dev/null
+++ b/comments/restore-comments-typed.rkt
@@ -0,0 +1,130 @@
+#lang racket
+
+(require (rename-in syntax/parse [...+ …+])
+ syntax/stx
+ racket/match
+ racket/set
+ racket/list
+ racket/function
+ racket/vector
+ racket/contract
+ sexp-diff
+ racket/pretty
+ rackunit
+ (only-in racket/base [... …])
+ (for-syntax (rename-in racket/base [... …]))
+ "syntax-properties.rkt")
+
+(provide restore-#%comment)
+
+(define/contract (restore-#%comment stx
+ #:replace-with (replace-with #f)
+ #:scope [scope (datum->syntax #f 'zero)])
+ (->* (syntax?)
+ (#:replace-with [or/c #f syntax? (-> syntax? syntax?)]
+ #:scope identifier?)
+ syntax?)
+ (define (erase-props stx)
+ (define stx* (if (syntax-property stx 'first-comments)
+ (syntax-property stx 'first-comments #f)
+ stx))
+ (if (syntax-property stx* 'comments-after)
+ (syntax-property stx* 'comments-after #f)
+ stx*))
+ (define (recur stx)
+ (restore-#%comment stx #:replace-with replace-with #:scope scope))
+ (define (replace-in commentᵢ)
+ (syntax-parse commentᵢ
+ #:datum-literals (#%comment)
+ [({~and c #%comment} . rest)
+ (if (syntax? replace-with)
+ (datum->syntax commentᵢ
+ `(,(datum->syntax #'c replace-with #'c #'c)
+ . ,((make-syntax-delta-introducer
+ scope
+ (datum->syntax #f 'zero))
+ #'rest
+ 'add))
+ commentᵢ
+ commentᵢ)
+ (replace-with
+ (datum->syntax commentᵢ
+ `(,#'c
+ . ,((make-syntax-delta-introducer
+ scope
+ (datum->syntax #f 'zero))
+ #'rest
+ 'add))
+ commentᵢ
+ commentᵢ)))]
+ [_
+ commentᵢ]))
+ (define (replace-in-after comments)
+ (if replace-with
+ (if (eq? comments #f)
+ comments
+ (stx-map replace-in comments))
+ comments))
+ (define (replace-in-first first-comments)
+ (define (replace-in-first1 first-comments)
+ (if (eq? first-comments #f)
+ first-comments
+ (cons (cons (caar first-comments)
+ (replace-in-first1 (cdar first-comments)))
+ (stx-map replace-in (cdr first-comments)))))
+ (if replace-with
+ (if (eq? first-comments #f)
+ first-comments
+ (cons (replace-in-first1 (car first-comments))
+ (stx-map replace-in (cdr first-comments))))
+ first-comments))
+ (match (syntax-e stx)
+ [(list* e* ... rest)
+ ;; TODO: when extracting the comments properties, check that they have
+ ;; the right shape (listof syntax?) or (*list/c syntax? (list/c R))
+ ;; Or append-map when stx is a stx-list (not in a tail position for the
+ ;; comments-after)
+ (define new-e*
+ (append-map (λ (eᵢ)
+ (cons (recur eᵢ)
+ (or (replace-in-after (extract-comments-after eᵢ))
+ '())))
+ e*))
+ (define new-rest
+ (if (syntax? rest)
+ (recur rest)
+ ;; TODO: handle vectors etc. here?
+ rest))
+ (define first-comments
+ (or (replace-in-first (extract-first-comments stx))
+ #f))
+ (define (nest first-comments to-nest)
+ (cond
+ [(eq? first-comments #f)
+ to-nest]
+ [(eq? (car first-comments) #f)
+ (append (cdr first-comments) to-nest)]
+ [else
+ (nest1 first-comments to-nest)]))
+ (define (nest1 first-comments to-nest)
+ (if (eq? first-comments #f)
+ to-nest
+ (append (cdr first-comments)
+ (datum->syntax (caar first-comments)
+ (nest (cdar first-comments) to-nest)))))
+ (define new-stx
+ (nest first-comments (append new-e* new-rest)))
+ (erase-props (datum->syntax stx new-stx stx stx))]
+ ;; TODO: recurse down vectors etc.
+ [(? vector? v)
+ ;; TODO: what if there is a first-comment property on the vector itself?
+ (erase-props
+ (datum->syntax stx
+ (vector-map (λ (vᵢ)
+ (recur vᵢ))
+ v)
+ stx
+ stx))]
+ [other
+ 'TODO…
+ other]))
\ No newline at end of file
diff --git a/test/comments/annotate-syntax-typed.rkt b/test/comments/annotate-syntax-typed.rkt
index 8e465787..debeca67 100644
--- a/test/comments/annotate-syntax-typed.rkt
+++ b/test/comments/annotate-syntax-typed.rkt
@@ -5,13 +5,13 @@
(provide annotate-syntax)
-(: annotate-syntax (->* (Syntax)
+(: annotate-syntax (->* (ISyntax/Non)
(#:srcloc+scopes? Boolean)
Sexp/Non))
(define (annotate-syntax e #:srcloc+scopes? [srcloc+scopes? #f])
(annotate-syntax1 e srcloc+scopes?))
-(: annotate-syntax1 (→ (U Syntax Syntax-E)
+(: annotate-syntax1 (→ (U ISyntax/Non ISyntax/Non-E)
Boolean
Sexp/Non))
(define (annotate-syntax1 e srcloc+scopes?)
@@ -52,14 +52,18 @@
(immutable? e)
(map (λ (eᵢ) (annotate-syntax1 eᵢ srcloc+scopes?))
(vector->list e)))]
- [(symbol? e)
+ [(box? e)
+ (list 'box
+ (immutable? e)
+ (annotate-syntax1 (unbox e) srcloc+scopes?))]
+ [(or (symbol? e)
+ (string? e)
+ (boolean? e)
+ (char? e)
+ (number? e)
+ (keyword? e))
e]
- [(string? e)
- e]
- [else
- (raise-argument-error
- 'annotate-syntax
- (string-append "a syntax object containing recursively on of the"
- " following: pair, null, vector, symbol, string")
- 0
- e)]))
\ No newline at end of file
+ [(NonSyntax? e)
+ (list 'NonSyntax (NonSexp (NonSyntax-v e)))]
+ [(NonSexp? e)
+ (list 'NonSexp e)]))
\ No newline at end of file
diff --git a/test/comments/same-syntax-typed.rkt b/test/comments/same-syntax-typed.rkt
new file mode 100644
index 00000000..6cfbe065
--- /dev/null
+++ b/test/comments/same-syntax-typed.rkt
@@ -0,0 +1,33 @@
+#lang typed/racket
+
+(require "annotate-syntax-typed.rkt"
+ tr-immutable/typed-syntax
+ rackunit)
+
+(require typed/racket/unsafe)
+(unsafe-require/typed sexp-diff
+ [sexp-diff (case→
+ (→ Sexp Sexp Sexp)
+ (→ Sexp/Non Sexp/Non Sexp/Non)
+ (→ (Sexpof Any) (Sexpof Any) (Sexpof Any)))])
+
+(provide check-same-syntax)
+
+(: same-syntax! (→ ISyntax/Non ISyntax/Non Boolean))
+(define (same-syntax! a b)
+ (define answer (equal? (annotate-syntax a #:srcloc+scopes? #f)
+ (annotate-syntax b #:srcloc+scopes? #f)))
+ (unless answer
+ (pretty-write
+ (sexp-diff (annotate-syntax a)
+ (annotate-syntax b)))
+ (displayln a)
+ (displayln b))
+ answer)
+
+(define-syntax (check-same-syntax stx)
+ (syntax-case stx ()
+ [(_ a b)
+ (datum->syntax #'here
+ `(check-true (same-syntax! ,#'a ,#'b))
+ stx)]))
\ No newline at end of file