www

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README

hide-comments-typed.rkt (4984B)

      1 #lang typed/racket
      2 
      3 (require (rename-in syntax/parse [...+ …+])
      4          syntax/stx
      5          racket/match
      6          racket/set
      7          racket/list
      8          racket/function
      9          racket/vector
     10          racket/contract
     11          sexp-diff
     12          racket/pretty
     13          rackunit
     14          (only-in racket/base [... …])
     15          (for-syntax (rename-in racket/base [... …]))
     16          tr-immutable/typed-syntax
     17          "syntax-properties-typed.rkt")
     18 
     19 (provide hide-#%comment)
     20 
     21 ;;    ([#%comment c1] a [#%comment c2] . ([#%comment c3] b [#%comment c4]))
     22 ;; => (aᶜ² . (bᶜ⁴)⁻ᶜ³)⁻ᶜ¹
     23 ;;    (c1 a c2 . (c3 . (c4 b c5)))
     24 ;; => (aᶜ² . (bᶜ⁵)⁻ᶜ³⁻⁻ᶜ⁴)⁻ᶜ¹
     25 ;;    (c1 a c2 . (c3 . (c4 c5)))
     26 ;; => (aᶜ² . ()⁻ᶜ³⁻⁻ᶜ⁴ᶜ⁵)⁻ᶜ¹
     27 ;;    (c1 a (c2) b)
     28 ;; => (a ()⁻ᶜ² b)⁻ᶜ¹
     29 ;;    (c1 a (c2 . b) c)
     30 ;; => (a b⁻ᶜ² c)⁻ᶜ¹
     31 ;;    (c1 a (c2 . (c3 c4)) c)
     32 ;; => (a ()⁻ᶜ²⁻⁻ᶜ³ᶜ⁴ c)⁻ᶜ¹
     33 (: hide-#%comment (→ ISyntax/Non-Stx ISyntax/Non-Stx))
     34 (define (hide-#%comment stx)
     35   (cond
     36     [(pair? (syntax-e stx))
     37      (hide-in-pair (syntax-e stx))]
     38     [else
     39      ;; TODO: recurse down vectors etc.
     40      stx]))
     41 
     42 (define-type ISyntax/Non-List*
     43   (Rec L (U ISyntax/Non
     44             Null
     45             (Pairof ISyntax/Non L))))
     46 
     47 (define pair (ann cons (∀ (A B) (→ A B (Pairof A B)))))
     48 
     49 (: hide-in-pair (→ ISyntax/Non-List*
     50                    ISyntax/Non-Stx))
     51 (define (hide-in-pair e*)
     52   (let loop ([rest : ISyntax/Non-List* e*]
     53              [groups : (Pairof (Listof Comment)
     54                                (Listof (Pairof ISyntax/Non (Listof Comment))))
     55                      '(())])
     56     (if (pair? rest)
     57         (if (comment? (car rest))
     58             (loop (cdr rest)
     59                   (pair (pair (ann (car rest) Comment) (car groups))
     60                         (cdr groups)))
     61             (loop (cdr rest)
     62                   (pair (ann '() (Listof Comment))
     63                         (pair (pair (car rest) (reverse (car groups)))
     64                               (cdr groups)))))
     65         (values rest groups)))
     66   (error "TODOrtfdsvc"))
     67 
     68 (define-type Comment (Syntaxof (Pairof (Syntaxof '#%comment) Any)))
     69 (define comment? (make-predicate Comment))
     70 
     71 
     72 #;(if ((make-predicate (Rec R (Pairof (Syntaxof (Pairof (Syntaxof '#%comment) Any))
     73                                       (U Boolean
     74                                          Char
     75                                          Number
     76                                          Keyword
     77                                          Null
     78                                          String
     79                                          Symbol
     80                                          BoxTop
     81                                          VectorTop
     82                                          R))))
     83        e*)
     84       (error "TODOwa" e*)
     85       (error "TODOwa" e*))
     86 
     87 #|
     88 (: listof? (∀ (A) (→ Any (→ Any Boolean : A) Boolean : (Listof A))))
     89 (define (listof? l p?)
     90   (pair? l
     91          p?
     92          (ann (λ (a)
     93                 (list*? a p?))
     94               (→ Any Boolean : ))
     95 |#
     96 
     97 #;(match (syntax-e stx)
     98     [(not (? pair?))
     99      ;; TODO: recurse down vectors etc.
    100      stx]
    101     [(list* e* ... rest)
    102      (error "TODO")
    103      #;(syntax-parse e*
    104          #:datum-literals (#%comment)
    105          [({~and c₀ [#%comment . _]} …
    106            {~seq {~and eᵢ {~not [#%comment . _]}}
    107                  {~and cᵢⱼ [#%comment . _]} …}
    108            …+)
    109           (define new-e* (map with-comments-after
    110                               (map hide-#%comment
    111                                    (syntax->list #'(eᵢ …)))
    112                               (map syntax->list
    113                                    (syntax->list #'((cᵢⱼ …) …)))))
    114           (define new-rest (if (null? rest)
    115                                rest
    116                                (hide-#%comment rest)))
    117           (with-first-comments
    118            (datum->syntax stx (append new-e* new-rest) stx stx)
    119            (cons #f (syntax->list #'(c₀ …))))]
    120          [({~and c₀ [#%comment . _]} …)
    121           (define new-rest (if (null? rest)
    122                                rest
    123                                (hide-#%comment rest)))
    124           (with-first-comments
    125            (with-comments-after
    126             (datum->syntax stx new-rest stx stx)
    127             (if (syntax? new-rest)
    128                 (syntax-property new-rest 'comments-after)
    129                 '()))
    130            (cons (if (syntax? new-rest)
    131                      (cons (datum->syntax new-rest
    132                                           'saved-props+srcloc
    133                                           new-rest
    134                                           new-rest)
    135                            (or (syntax-property new-rest 'first-comments)
    136                                ;; TODO: I'm dubious about this, better typecheck
    137                                ;; everything…
    138                                (cons #f null)))
    139                      #f)
    140                  (syntax->list #'(c₀ …))))])])