Attempt at typing hide-#%comment, it looks horrible.
This commit is contained in:
Georges Dupéron
parent
0fbcd59af2
commit
674af96a89
140
comments/hide-comments-typed.rkt
Normal file
140
comments/hide-comments-typed.rkt
Normal file
|
|
@ -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₀ …))))])])
|
||||
130
comments/restore-comments-typed.rkt
Normal file
130
comments/restore-comments-typed.rkt
Normal file
|
|
@ -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]))
|
||||
|
|
@ -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)]))
|
||||
[(NonSyntax? e)
|
||||
(list 'NonSyntax (NonSexp (NonSyntax-v e)))]
|
||||
[(NonSexp? e)
|
||||
(list 'NonSexp e)]))
|
||||
33
test/comments/same-syntax-typed.rkt
Normal file
33
test/comments/same-syntax-typed.rkt
Normal file
|
|
@ -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)]))
|
||||
Loading…
Reference in New Issue
Block a user