blob: bdce71d50751caaded20337f255413466b6dd914 (
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
116
117
118
|
## 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]
))
## [Utils]
(def: (function$ func inputs output)
(-> AST (List AST) AST AST)
(case inputs
#;Nil
output
_
(` (lambda (~@ (if (list;empty? inputs) (list) (list func)))
[(~@ inputs)]
(~ output)))))
## [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>]
[Deg poly;deg number;Eq<Deg>]
[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 members] (poly;variant :x:)
#let [new-env (poly;extend-env [:x: g!type-fun]
(list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
env)]
pattern-matching (mapM @
(lambda [[name :case:]]
(do @
[g!eq (Eq<?> new-env :case:)]
(wrap (list (` [((~ (ast;tag name)) (~ g!left))
((~ (ast;tag name)) (~ g!right))])
(` ((~ g!eq) (~ g!left) (~ g!right)))))))
members)
#let [base (function$ g!type-fun g!vars
(` (lambda [(~ g!left) (~ g!right)]
(case [(~ g!left) (~ g!right)]
(~@ (List/join pattern-matching))))))]]
(wrap (` (: (~ (poly;gen-type new-env ->Eq g!type-fun g!vars :x:))
(~ base))))))
## Tuples
(with-gensyms [g!type-fun]
(do @
[[g!vars members] (poly;tuple :x:)
#let [new-env (poly;extend-env [:x: g!type-fun]
(list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
env)]
pattern-matching (mapM @
(lambda [:member:]
(do @
[g!left (compiler;gensym "g!left")
g!right (compiler;gensym "g!right")
g!eq (Eq<?> new-env :member:)]
(wrap [g!left g!right g!eq])))
members)
#let [.left. (` [(~@ (List/map product;left pattern-matching))])
.right. (` [(~@ (List/map (|>. product;right product;left) pattern-matching))])
base (function$ g!type-fun g!vars
(` (lambda [(~ .left.) (~ .right.)]
(and (~@ (List/map (lambda [[g!left g!right g!eq]]
(` ((~ g!eq) (~ g!left) (~ g!right))))
pattern-matching))))))]]
(wrap (` (: (~ (poly;gen-type new-env ->Eq g!type-fun g!vars :x:))
(~ base))))))
## Type recursion
(poly;recur env :x:)
## 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:)))
))))
|
