www

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

test-flexible-with.rkt (1909B)

      1 #lang dotlambda/unhygienic type-expander/lang
      2 
      3 (require (lib "phc-graph/flexible-with.hl.rkt")
      4          (for-syntax racket/syntax
      5                      racket/list
      6                      (rename-in racket/base [... …]))
      7          phc-toolkit
      8          typed-map
      9          type-expander)
     10 
     11 (define-syntax (gs stx)
     12   (syntax-case stx ()
     13     [(_ bt-fields-id nfields (f …) [struct struct-field …] …)
     14      (let ()
     15        (define/with-syntax (field …)
     16          (append (syntax->list #'(f …))
     17                  (map (λ (_) (datum->syntax #'nfields (gensym 'g)))
     18                       (range (- (syntax-e #'nfields)
     19                                 (length (syntax->list #'(f …))))))))
     20        (define-trees #'(bt-fields-id
     21                         (field …)
     22                         [struct struct-field …] …)))]))
     23 
     24 (gs bt-fields
     25     16
     26     (a b c)
     27     [sab a b]
     28     [sbc b c]
     29     [sabc a b c])
     30 
     31 (define-type btac (bt-fields a c))
     32 
     33 (check-equal?:
     34  (~> (ann (with-c (sab→tree 1 2) 'nine)
     35           ((bt-fields a b c) One Positive-Byte 'nine))
     36      force
     37      flatten
     38      (filter Some? _)
     39      (map Some-v _)
     40      list->set)
     41  (set 1 2 'nine))
     42  
     43 
     44 (check-equal?:
     45  (call-with-values
     46   λ.(tree→sab (sab→tree 1 2))
     47   list)
     48  '(1 2))
     49        
     50 (check-equal?:
     51  (call-with-values
     52   λ.(tree→sabc (ann (with-c (sab→tree 1 2) 'nine)
     53                      ((bt-fields a b c) One Positive-Byte 'nine)))
     54   list)
     55  '(1 2 nine))
     56 
     57 (check-equal?:
     58  (call-with-values
     59   λ.(tree→sabc (with-c (sab→tree 'NONE 'NONE) 'NONE))
     60   list)
     61  '(NONE NONE NONE))
     62 
     63 (check-equal?:
     64  (call-with-values
     65   λ.(tree→sab (without-c (with-c (sab→tree 'NONE 'NONE) 'NONE)))
     66   list)
     67  '(NONE NONE))
     68 
     69 (check-equal?:
     70  (call-with-values
     71   λ.(tree→sbc (without-a (with-c (sab→tree 'NONE 'NONE) 'NONE)))
     72   list)
     73  '(NONE NONE))
     74 
     75 (check-equal?:
     76  (call-with-values
     77   λ.(tree→sbc (without-a (with-c (sab→tree 1 2) 3)))
     78   list)
     79  '(2 3))