www

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

repeat-stx.rkt (2893B)

      1 #lang typed/racket
      2 (require "typed-untyped.rkt")
      3 (define-typed/untyped-modules #:no-test
      4   (provide repeat-stx)
      5   
      6   (require syntax/stx
      7            (for-syntax racket/base
      8                        racket/syntax
      9                        syntax/parse))
     10   
     11   (define-for-syntax (repeat-stx-2 stx)
     12     (syntax-parse stx
     13       [(a:id b:id)
     14        #'(λ _ a)]
     15       [(a:id (b:expr (~literal ...)))
     16        #`(λ (bs) (stx-map #,(repeat-stx-2 #'(a b)) bs))]))
     17   
     18   (define-for-syntax (repeat-stx-1 stx)
     19     (syntax-parse stx
     20       [(a:id b:expr)
     21        #`(λ (a bs) (#,(repeat-stx-2 #'(a b)) bs))]
     22       [((a:expr (~literal ...)) (b:expr (~literal ...)))
     23        #`(λ (s1 s2) (stx-map #,(repeat-stx-1 #'(a b)) s1 s2))]))
     24   
     25   (define-syntax (repeat-stx stx)
     26     (syntax-parse stx
     27       [(_ a:expr b:expr)
     28        #`(#,(repeat-stx-1 #'(a b)) #'a #'b)])))
     29 
     30 (module test racket
     31   (require (submod ".." untyped))
     32   (require syntax/parse
     33            rackunit)
     34   
     35   (check-equal?
     36    (syntax-parse #'(1 2)
     37      [(a b)
     38       (syntax->datum
     39        (datum->syntax
     40         #'dummy
     41         (repeat-stx a b)))])
     42    1)
     43   
     44   (check-equal?
     45    (syntax-parse #'(1 2 3)
     46      [(a b ...)
     47       (syntax->datum
     48        (datum->syntax
     49         #'dummy
     50         (repeat-stx a (b ...))))])
     51    '(1 1))
     52   
     53   (check-equal?
     54    (syntax-parse #'(1 (2 3) (uu vv ww) (xx yy))
     55      [(a (b ...) ...)
     56       (syntax->datum
     57        (datum->syntax
     58         #'dummy
     59         (repeat-stx a ((b ...) ...))))])
     60    '((1 1) (1 1 1) (1 1)))
     61   
     62   (check-equal?
     63    (syntax-parse #'(1 ((2) (3 3)) ((uu) (vv vv) (ww ww ww)) ((xx) (yy)))
     64      [(a ((b ...) ...) ...)
     65       (syntax->datum
     66        (datum->syntax
     67         #'dummy
     68         (repeat-stx a (((b ...) ...) ...))))])
     69    '(((1) (1 1)) ((1) (1 1) (1 1 1)) ((1) (1))))
     70   
     71   (check-equal?
     72    (syntax-parse #'([1 x] [2 y] [3 z])
     73      [([a b] ...)
     74       (syntax->datum
     75        (datum->syntax
     76         #'dummy
     77         (repeat-stx (a ...) (b ...))))])
     78    '(1 2 3))
     79   
     80   (check-equal?
     81    (syntax-parse #'((1 2 3) (a b))
     82      [([a b ...] ...)
     83       (syntax->datum
     84        (datum->syntax
     85         #'dummy
     86         (repeat-stx (a ...) ((b ...) ...))))])
     87    '((1 1) (a)))
     88   
     89   (check-equal?
     90    (syntax-parse #'(((1 2 3) (a b)) ((x y z t) (-1 -2)))
     91      [[[[a b ...] ...] ...]
     92       (syntax->datum
     93        (datum->syntax
     94         #'dummy
     95         (repeat-stx ((a ...) ...) (((b ...) ...) ...))))])
     96    '(((1 1) (a)) ((x x x) (-1))))
     97   
     98   (check-equal?
     99    (syntax-parse #'((f (1 2 3) (a b)) (g (x y z t) (-1 -2)))
    100      [[[a (b ...) ...] ...]
    101       (syntax->datum
    102        (datum->syntax
    103         #'dummy
    104         (repeat-stx (a ...) (((b ...) ...) ...))))])
    105    '(((f f f) (f f)) ((g g g g) (g g))))
    106   
    107   (check-equal?
    108    (syntax-parse #'((h () ()) (i () (x y z) ()))
    109      [([a (b ...) ...] ...)
    110       (syntax->datum
    111        (datum->syntax
    112         #'dummy
    113         (repeat-stx (a ...) (((b ...) ...) ...))))])
    114    '((() ()) (() (i i i) ()))))