aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/test/test/luxc/lang/translation/case.lux
blob: ca960dba4189b081d046ca88b35fd4f1be0023fe (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
(.module:
  lux
  (lux [io #+ IO]
       (control [monad #+ do]
                pipe)
       (data ["e" error]
             text/format
             (coll [list]))
       ["r" math/random "r/" Monad<Random>]
       [macro]
       (macro [code])
       test)
  (luxc [lang]
        (lang ["ls" synthesis]))
  (test/luxc common))

(def: struct-limit Nat +10)

(def: (tail? size idx)
  (-> Nat Nat Bool)
  (n/= (n/dec size) idx))

(def: upper-alpha-ascii
  (r.Random Nat)
  (|> r.nat (:: r.Functor<Random> map (|>> (n/% +91) (n/max +65)))))

(def: gen-case
  (r.Random [ls.Synthesis ls.Path])
  (<| r.rec (function (_ gen-case))
      (`` ($_ r.either
              (r/wrap [(' []) (' ("lux case pop"))])
              (~~ (do-template [<gen> <synth>]
                    [(do r.Monad<Random>
                       [value <gen>]
                       (wrap [(<synth> value) (<synth> value)]))]

                    [r.bool code.bool]
                    [r.nat code.nat]
                    [r.int code.int]
                    [r.deg code.deg]
                    [r.frac code.frac]
                    [(r.text' upper-alpha-ascii +5) code.text]))
              (do r.Monad<Random>
                [size (|> r.nat (:: @ map (|>> (n/% struct-limit) (n/max +2))))
                 idx (|> r.nat (:: @ map (n/% size)))
                 [subS subP] gen-case
                 #let [caseS (` [(~+ (list.concat (list (list.repeat idx (' []))
                                                        (list subS)
                                                        (list.repeat (|> size n/dec (n/- idx)) (' [])))))])
                       caseP (` ("lux case seq"
                                 (~ (if (tail? size idx)
                                      (` ("lux case tuple right" (~ (code.nat idx))))
                                      (` ("lux case tuple left" (~ (code.nat idx))))))
                                 (~ subP)))]]
                (wrap [caseS caseP]))
              (do r.Monad<Random>
                [size (|> r.nat (:: @ map (|>> (n/% struct-limit) (n/max +2))))
                 idx (|> r.nat (:: @ map (n/% size)))
                 [subS subP] gen-case
                 #let [caseS (` ((~ (code.nat idx)) (~ (code.bool (tail? size idx))) (~ subS)))
                       caseP (` ("lux case seq"
                                 (~ (if (tail? size idx)
                                      (` ("lux case variant right" (~ (code.nat idx))))
                                      (` ("lux case variant left" (~ (code.nat idx))))))
                                 (~ subP)))]]
                (wrap [caseS caseP]))
              ))))

(def: (pattern-matching-spec run)
  (-> (-> ls.Synthesis (e.Error Top)) Test)
  (do r.Monad<Random>
    [[valueS pathS] gen-case
     to-bind r.nat]
    ($_ seq
        (test "Can translate pattern-matching."
              (|> (run (` ("lux case" (~ valueS)
                           ("lux case alt"
                            ("lux case seq" (~ pathS)
                             ("lux case exec" true))
                            ("lux case seq" ("lux case bind" +0)
                             ("lux case exec" false))))))
                  (case> (#e.Success valueT)
                         (:! Bool valueT)

                         (#e.Error error)
                         false)))
        (test "Can bind values."
              (|> (run (` ("lux case" (~ (code.nat to-bind))
                           ("lux case seq" ("lux case bind" +0)
                            ("lux case exec" (0))))))
                  (case> (#e.Success valueT)
                         (n/= to-bind (:! Nat valueT))

                         (#e.Error error)
                         false))))))

(context: "[JVM] Pattern-matching."
  (<| (times +100)
      (pattern-matching-spec run-jvm)))

(context: "[JS] Pattern-matching."
  (<| (times +100)
      (pattern-matching-spec run-js)))

(context: "[Lua] Pattern-matching."
  (<| (times +100)
      (pattern-matching-spec run-lua)))

(context: "[Ruby] Pattern-matching."
  (<| (times +100)
      (pattern-matching-spec run-ruby)))

(context: "[Python] Function."
  (<| (times +100)
      (pattern-matching-spec run-python)))