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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
(;module:
lux
(lux (control monad
[codec])
(data [text]
text/format
(coll [list "List/" Monad<List>]
[dict #+ Dict])
[number]
[product]
[bool]
[char]
[maybe]
[ident "Ident/" Codec<Text,Ident>])
[macro #+ Monad<Lux> with-gensyms]
(macro [code]
[syntax #+ syntax: Syntax]
(syntax [common])
[poly #+ poly:])
[type]
))
(def: (function$ func inputs output)
(-> Code (List Code) Code Code)
(case inputs
#;Nil
output
_
(` (function (~@ (if (list;empty? inputs) (list) (list func)))
[(~@ inputs)]
(~ output)))))
## [Derivers]
(poly: #export (Codec<Text,?>::encode env :x:)
(let [->Codec::encode (: (-> Code Code)
(function [.type.] (` (-> (~ .type.) Text))))]
(with-expansions
[<basic> (do-template [<type> <matcher> <encoder>]
[(do @
[_ (<matcher> :x:)]
(wrap (` (: (~ (->Codec::encode (` <type>)))
(~' <encoder>)))))]
[Unit poly;unit (function [_0] "[]")]
[Bool poly;bool (:: bool;Codec<Text,Bool> encode)]
[Nat poly;nat (:: number;Codec<Text,Nat> encode)]
[Int poly;int (:: number;Codec<Text,Int> encode)]
[Deg poly;deg (:: number;Codec<Text,Deg> encode)]
[Real poly;real (:: number;Codec<Text,Real> encode)]
[Char poly;char (:: char;Codec<Text,Char> encode)]
[Text poly;text (:: text;Codec<Text,Text> encode)])]
($_ macro;either
## Primitives
<basic>
## Variants
(with-gensyms [g!type-fun g!case g!input]
(do @
[[g!vars cases] (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 @
(function [[name :case:]]
(do @
[encoder (Codec<Text,?>::encode new-env :case:)]
(wrap (list (` ((~ (code;tag name)) (~ g!case)))
(` (format "(#"
(~ (code;text (Ident/encode name)))
" "
((~ encoder) (~ g!case))
")"))))))
cases)
#let [base (function$ g!type-fun g!vars
(` (function [(~ g!input)]
(case (~ g!input)
(~@ (List/join pattern-matching))))))]]
(wrap (` (: (~ (poly;gen-type env ->Codec::encode g!type-fun g!vars :x:))
(~ base)
)))))
## Records
(with-gensyms [g!type-fun g!case g!input]
(do @
[[g!vars slots] (poly;record :x:)
#let [new-env (poly;extend-env [:x: g!type-fun]
(list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
env)]
synthesis (mapM @
(function [[name :slot:]]
(do @
[encoder (Codec<Text,?>::encode new-env :slot:)]
(wrap (` (format "#"
(~ (code;text (Ident/encode name)))
" "
((~ encoder) (get@ (~ (code;tag name)) (~ g!input))))))))
slots)
#let [base (function$ g!type-fun g!vars
(` (function [(~ g!input)]
(format "{" (~@ (list;interpose (' " ") synthesis)) "}"))))]]
(wrap (` (: (~ (poly;gen-type env ->Codec::encode g!type-fun g!vars :x:))
(~ base)
)))))
## Tuples
(with-gensyms [g!type-fun g!case g!input]
(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)]
parts (mapM @
(function [:member:]
(do @
[g!member (macro;gensym "g!member")
encoder (Codec<Text,?>::encode new-env :member:)]
(wrap [g!member encoder])))
members)
#let [analysis (` [(~@ (List/map product;left parts))])
synthesis (List/map (function [[g!member g!encoder]]
(` ((~ g!encoder) (~ g!member))))
parts)
base (function$ g!type-fun g!vars
(` (function [(~ g!input)]
(case (~ g!input)
(~ analysis)
(format "[" (~@ (list;interpose (' " ") synthesis)) "]")))))]]
(wrap (` (: (~ (poly;gen-type env ->Codec::encode g!type-fun g!vars :x:))
(~ base)
)))))
## Type recursion
(poly;recur env :x:)
## Type applications
(do @
[[:func: :args:] (poly;apply :x:)
.func. (Codec<Text,?>::encode env :func:)
.args. (mapM @ (Codec<Text,?>::encode env) :args:)]
(wrap (` (: (~ (->Codec::encode (type;to-ast :x:)))
((~ .func.) (~@ .args.))))))
## Bound type-variables
(poly;bound env :x:)
## Failure...
(macro;fail (format "Cannot create Text encoder for: " (%type :x:)))
))))
|
