www

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

test-define-adt.rkt (5453B)

      1 #lang typed/racket
      2 
      3 (require phc-adt
      4          phc-toolkit
      5          type-expander
      6          typed/rackunit
      7          (only-in (lib "phc-adt/tagged-structure-low-level.hl.rkt")
      8                   λ-tagged-get-field))
      9 (adt-init)
     10 
     11 ;(define-constructor c2 : Fixnum String)
     12 
     13 ;; define-tagged
     14 (begin
     15   (define-tagged tagged-s1)
     16   (define-tagged tagged-s2 [f Fixnum] [g String])
     17   (define-tagged tagged-s3 [g String] [f Fixnum])
     18   (define-tagged tagged-s4 [f Fixnum] [g String])
     19   
     20   (check-equal?: (match (ann (tagged-s1) (tagged tagged-s1))
     21                    [(tagged-s1) #t])
     22                  #t)
     23     
     24   (check-equal?: (match (ann (tagged-s2 99 "z") tagged-s2)
     25                    [(tagged-s2 f g) (cons g f)])
     26                  '("z" . 99))
     27     
     28   (let ()
     29     (check-equal?: (match (ann (tagged-s2 99 "in-let") tagged-s2)
     30                      [(tagged-s2 f g) (cons g f)])
     31                    '("in-let" . 99)))
     32     
     33   (define (test-match val)
     34     (match val
     35       [(tagged-s2 x y) (list 'found-s2 y x)]
     36       [(tagged-s3 x y) (list 'found-s3 y x)]
     37       [(tagged-s4 x y) (list 'found-s4 y x)]))
     38     
     39   (check-equal?:
     40    (test-match (ann (tagged-s2 2 "flob")
     41                     (tagged tagged-s2 [f Fixnum] [g String])))
     42    '(found-s2 "flob" 2))
     43     
     44   (check-equal?:
     45    (test-match (ann (tagged-s3 "flob" 2)
     46                     (tagged tagged-s3 [g String] [f Fixnum])))
     47    '(found-s3 2 "flob"))
     48 
     49   ;; g and f are inverted in the “ann”
     50   (check-equal?:
     51    (test-match (ann (tagged-s4 2 "flob")
     52                     (tagged tagged-s4 [g String] [f Fixnum])))
     53    '(found-s4 "flob" 2))
     54     
     55   (define (test-match-verbose val)
     56     (match val
     57       [(tagged tagged-s2 g [f y]) (list 'found-s2 g y)]
     58       [(tagged tagged-s3 [g y] f) (list 'found-s2 f y)]
     59       [(tagged tagged-s4 [f y] g) (list 'found-s2 g y)]))
     60     
     61   (check-equal?:
     62    (test-match (ann (tagged-s2 3 "flob")
     63                     (tagged tagged-s2 [f Fixnum] [g String])))
     64    '(found-s2 "flob" 3))
     65     
     66   ;; g and f are inverted in the “ann”
     67   (check-equal?:
     68    (test-match (ann (tagged-s3 "flob" 3)
     69                     (tagged tagged-s3 [f Fixnum] [g String])))
     70    '(found-s3 3 "flob"))
     71     
     72   (check-equal?:
     73    (test-match (ann (tagged-s4 3 "flob")
     74                     (tagged tagged-s4 [f Fixnum] [g String])))
     75    '(found-s4 "flob" 3))
     76     
     77   (check-not-equal?: (tagged-s2 4 "flob")
     78                      (tagged-s3 "flob" 4))
     79   (check-not-equal?: (tagged-s2 4 "flob")
     80                      (tagged-s4 4 "flob")))
     81 
     82 ;; define-constructor
     83 (begin
     84   (define-constructor c1 :)
     85   (define-constructor c2 : Fixnum String)
     86   (define-constructor c3 : Fixnum String)
     87     
     88   (check-equal?: (match (ann (c1) (constructor c1))
     89                    [(c1) #t])
     90                  #t)
     91     
     92   (check-equal?: (match (ann (c2 99 "z") c2)
     93                    [(c2 f g) (cons g f)])
     94                  '("z" . 99))
     95     
     96   (let ()
     97     (check-equal?: (match (ann (c2 99 "in-let") c2)
     98                      [(c2 f g) (cons g f)])
     99                    '("in-let" . 99)))
    100     
    101   (define (test-c-match val)
    102     (match val
    103       [(c1) (list 'found-c1)]
    104       [(constructor c2 x y z) (list 'found-c2-xyz z y x)]
    105       [(c2 x y) (list 'found-c2 y x)]
    106       [(c3 x y) (list 'found-c3 y x)]))
    107     
    108   (check-equal?:
    109    (test-c-match (ann (c2 2 "flob")
    110                       (constructor c2 Fixnum String)))
    111    '(found-c2 "flob" 2))
    112     
    113   (check-equal?:
    114    (test-c-match (ann (c3 2 "flob")
    115                       (constructor c3 Fixnum String)))
    116    '(found-c3 "flob" 2)))
    117 
    118 ;; define-tagged (used to use #:private, updated the tests now that the option
    119 ;; was removed).
    120 (begin
    121   (define-syntax-rule (defp make mt)
    122     (begin
    123       (define-tagged txyz #:? txyz?
    124         [a Number]
    125         [b String])
    126         
    127       (define (make) (txyz 1 "b"))
    128         
    129       (define (mt v)
    130         (match v
    131           ((txyz x y) (list 'macro y x))
    132           (_ #f)))))
    133     
    134   (defp make mt)
    135     
    136   (define-tagged txyz #:? txyz?
    137     [a Number]
    138     [b String])
    139     
    140   (check-equal?: (match (make)
    141                    ((tagged txyz x y) (list 'out y x))
    142                    (_ #f))
    143                  #f)
    144     
    145   (check-equal?: (mt (tagged txyz [x 1] [y "b"]))
    146                  #f)
    147     
    148   (check-equal?: (mt (make))
    149                  '(macro "b" 1))
    150     
    151   (check-equal?: (make) (txyz 1 "b"))
    152   (check-equal?: (match (make)
    153                    ((txyz x y) (list 'out y x))
    154                    (_ #f))
    155                  '(out "b" 1))
    156     
    157   (check-equal?: (mt (txyz 1 "b"))
    158                  '(macro "b" 1)))
    159   
    160 ;; define-constructor #:private
    161 (begin
    162   (define-syntax-rule (defpc makec mtc)
    163     (begin
    164       (define-constructor cxyz #:? cxyz? : Number String)
    165         
    166       (define (makec) (cxyz 1 "b"))
    167         
    168       (define (mtc v)
    169         (match v
    170           ((cxyz x y) (list 'macro y x))
    171           (_ #f)))))
    172     
    173   (defpc makec mtc)
    174     
    175   (define-constructor cxyz #:? cxyz? : Number String)
    176     
    177   (check-equal?: (match (makec)
    178                    ((constructor cxyz e f) (list 'out f e))
    179                    (_ #f))
    180                  '(out "b" 1))
    181     
    182   (check-equal?: (mtc (constructor cxyz 1 "b"))
    183                  '(macro "b" 1))
    184     
    185   (check-equal?: (mtc (makec))
    186                  '(macro "b" 1))
    187     
    188   (check-equal?: (makec) (cxyz 1 "b"))
    189   (check-equal?: (match (makec)
    190                    ((cxyz e f) (list 'out f e))
    191                    (_ #f))
    192                  '(out "b" 1))
    193     
    194   (check-equal?: (mtc (cxyz 1 "b"))
    195                  '(macro "b" 1)))