www

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

syntax-properties-typed.rkt (2662B)

      1 #lang typed/racket
      2 
      3 (provide First-Comments
      4          Comments-After
      5          with-first-comments
      6          with-comments-after
      7          extract-first-comments
      8          extract-comments-after)
      9 
     10 (require tr-immutable/typed-syntax
     11          typed-map)
     12 
     13 (define-type First-Comments
     14   (Rec R (Pairof (U #f (Pairof (Syntaxof 'saved-props+srcloc)
     15                                R))
     16                  (Listof ISyntax))))
     17 
     18 (define-type Comments-After
     19   (Listof ISyntax))
     20 
     21 (: first-comments? (→ Any Boolean : (Pairof (U #f (Pairof (Syntaxof 'saved-props+srcloc)
     22                                                           First-Comments))
     23                                             (Listof ISyntax))))
     24 (define (first-comments? v)
     25   (define p? (inst pairof?
     26                    (U #f (Pairof (Syntaxof 'saved-props+srcloc)
     27                                  First-Comments))
     28                    (Listof ISyntax)))
     29   (p? v first-comments1? first-comments2?))
     30 
     31 (: first-comments1? (→ Any Boolean : (U #f (Pairof (Syntaxof 'saved-props+srcloc)
     32                                                    First-Comments))))
     33 (define (first-comments1? v)
     34   (or (false? v)
     35       (first-comments11? v)))
     36 
     37 (: first-comments11? (→ Any Boolean : (Pairof (Syntaxof 'saved-props+srcloc)
     38                                               First-Comments)))
     39 (define (first-comments11? v)
     40   (define p? (inst pairof?
     41                    (Syntaxof 'saved-props+srcloc)
     42                    First-Comments))
     43   (p? v
     44       (make-predicate (Syntaxof 'saved-props+srcloc))
     45       first-comments?))
     46 
     47 (: first-comments2? (→ Any Boolean : (Listof ISyntax)))
     48 (define (first-comments2? v)
     49   (and (list? v)
     50        (andmap isyntax? v)))
     51 
     52 (: with-first-comments (∀ (A) (→ ISyntax
     53                                  (U #f First-Comments)
     54                                  ISyntax)))
     55 (define (with-first-comments e c)
     56     
     57   (if (or (not c) (and (= (length c) 1) (not (first c))))
     58       e
     59       (syntax-property e 'first-comments c)))
     60 
     61 (: with-comments-after (∀ (A) (→ (Syntaxof A)
     62                                  (U #f Comments-After)
     63                                  (Syntaxof A))))
     64 (define (with-comments-after e c)
     65   (if (or (not c) (null? c))
     66       e
     67       (syntax-property e 'comments-after c)))
     68 
     69 (: extract-first-comments (-> (Syntaxof Any) (U #f First-Comments)))
     70 (define (extract-first-comments stx)
     71   (define c (syntax-property stx 'first-comments))
     72   (if (first-comments? c)
     73       c
     74       #f))
     75 
     76 (: extract-comments-after (-> (Syntaxof Any) (U #f Comments-After)))
     77 (define (extract-comments-after stx)
     78   (define c (syntax-property stx 'comments-after))
     79   (and (list? c)
     80        (andmap isyntax? c)
     81        c))