From 674af96a8912178f2cd2d6716083b3d509a6c403 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Fri, 13 Jan 2017 00:55:56 +0100
Subject: [PATCH] Attempt at typing hide-#%comment, it looks horrible.

---
 comments/hide-comments-typed.rkt        | 140 ++++++++++++++++++++++++
 comments/restore-comments-typed.rkt     | 130 ++++++++++++++++++++++
 test/comments/annotate-syntax-typed.rkt |  28 +++--
 test/comments/same-syntax-typed.rkt     |  33 ++++++
 4 files changed, 319 insertions(+), 12 deletions(-)
 create mode 100644 comments/hide-comments-typed.rkt
 create mode 100644 comments/restore-comments-typed.rkt
 create mode 100644 test/comments/same-syntax-typed.rkt

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