blob: 025797751d5d674d80cee30d39d53ecf32e1ec41 (
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
|
## Copyright (c) Eduardo Julian. All rights reserved.
## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
## If a copy of the MPL was not distributed with this file,
## You can obtain one at http://mozilla.org/MPL/2.0/.
(;module:
lux
(lux (control monad
[eq])
(data [text]
text/format
(struct [list "List/" Monad<List>]
[dict #+ Dict])
[number]
[product]
[bool]
[char]
[maybe])
[compiler #+ Monad<Lux> with-gensyms]
(macro [ast]
[syntax #+ syntax: Syntax]
(syntax [common])
[poly #+ poly:])
[type]
))
## [Derivers]
(poly: #export (|Eq| env :x:)
(let [->Eq (: (-> AST AST)
(lambda [.type.] (` (eq;Eq (~ .type.)))))]
(let% [<basic> (do-template [<type> <matcher> <eq>]
[(do @
[_ (<matcher> :x:)]
(wrap (` (: (~ (->Eq (` <type>)))
<eq>))))]
[Unit poly;unit (lambda [(~' test) (~' input)] true)]
[Bool poly;bool bool;Eq<Bool>]
[Nat poly;nat number;Eq<Nat>]
[Int poly;int number;Eq<Int>]
[Frac poly;frac number;Eq<Frac>]
[Real poly;real number;Eq<Real>]
[Char poly;char char;Eq<Char>]
[Text poly;text text;Eq<Text>])]
($_ compiler;either
## Primitive types
<basic>
## Variants
(with-gensyms [g!type-fun g!left g!right]
(do @
[[g!vars cases] (poly;variant :x:)
#let [new-env (poly;extend-env g!type-fun g!vars env)]
pattern-matching (mapM @
(lambda [[name :case:]]
(do @
[encoder (|Eq| new-env :case:)]
(wrap (list (` [((~ (ast;tag name)) (~ g!left))
((~ (ast;tag name)) (~ g!right))])
(` ((~ encoder) (~ g!left) (~ g!right)))))))
cases)]
(wrap (` (: (~ (poly;gen-type ->Eq g!type-fun g!vars :x:))
(lambda [(~@ g!vars)]
(lambda [(~ g!left) (~ g!right)]
(case [(~ g!left) (~ g!right)]
(~@ (List/join pattern-matching)))))
)))))
## Tuples
(with-gensyms [g!type-fun g!left g!right]
(do @
[[g!vars members] (poly;tuple :x:)
#let [new-env (poly;extend-env g!type-fun g!vars env)]
pattern-matching (mapM @
(lambda [:member:]
(do @
[g!left (compiler;gensym "g!left")
g!right (compiler;gensym "g!right")
encoder (|Eq| new-env :member:)]
(wrap [g!left g!right encoder])))
members)
#let [.left. (` [(~@ (List/map product;left pattern-matching))])
.right. (` [(~@ (List/map (|>. product;right product;left) pattern-matching))])]]
(wrap (` (: (~ (poly;gen-type ->Eq g!type-fun g!vars :x:))
(lambda [(~@ g!vars)]
(lambda [(~ g!left) (~ g!right)]
(case [(~ g!left) (~ g!right)]
[(~ .left.) (~ .right.)]
(;;array (list (~@ (List/map (lambda [[g!left g!right g!encoder]]
(` ((~ g!encoder) (~ g!left) (~ g!right))))
pattern-matching)))))))
)))
))
## Type applications
(do @
[[:func: :args:] (poly;apply :x:)
.func. (|Eq| env :func:)
.args. (mapM @ (|Eq| env) :args:)]
(wrap (` (: (~ (->Eq (type;to-ast :x:)))
((~ .func.) (~@ .args.))))))
## Bound type-vars
(poly;bound env :x:)
## If all else fails...
(compiler;fail (format "Can't create Eq for: " (%type :x:)))
))))
|
