blob: 467fed7656ff301a133c2cdca0105c14cd9caeca (
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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
(.module:
lux
(lux (control [monad #+ do]
["p" parser "parser/" Monad<Parser>]
["ex" exception #+ exception:])
(data [product]
["e" error #+ Error]
[text "text/" Eq<Text>]
text/format
(coll [list "list/" Functor<List>]))
(macro [code]
["s" syntax #+ Syntax]))
[///lang])
(exception: #export (Invalid-Lux-Version {message Text})
message)
(def: (write-type type)
(-> Type Code)
(case type
(#.Primitive name params)
(` ("Primitive"
(~ (code.text name))
(~+ (list/map write-type params))))
(^template [<tag> <description>]
(<tag> left right)
(` (<description> (~ (write-type left)) (~ (write-type right)))))
([#.Sum "Sum"]
[#.Product "Product"]
[#.Function "Function"]
[#.Apply "Apply"])
(^template [<tag> <description>]
(<tag> id)
(` (<description> (~ (code.nat id)))))
([#.Bound "Bound"]
[#.Var "Var"]
[#.Ex "Ex"])
(^template [<tag> <description>]
(<tag> env body)
(` (<description> (~ (code.tuple (list/map write-type env)))
(~ (write-type body)))))
([#.UnivQ "UnivQ"]
[#.ExQ "ExQ"])
(#.Named name anonymous)
(` ("Named" (~ (code.symbol name)) (~ (write-type anonymous))))))
(def: read-type
(Syntax Type)
(let [tagged (: (All [a] (-> Text (Syntax a) (Syntax a)))
(function (_ tag syntax)
(s.form (p.after (s.this (code.text tag)) syntax))))
binary (: (-> Text (Syntax Type) (Syntax [Type Type]))
(function (_ tag read-type)
(tagged tag (p.seq read-type read-type))))
indexed (: (-> Text (Syntax Nat))
(function (_ tag)
(tagged tag s.nat)))
quantified (: (-> Text (Syntax Type) (Syntax [(List Type) Type]))
(function (_ tag read-type)
(tagged tag (p.seq (s.tuple (p.some read-type))
read-type))))]
(p.rec
(function (_ read-type)
($_ p.alt
(tagged "Primitive" (p.seq s.text (p.some read-type)))
(binary "Sum" read-type)
(binary "Product" read-type)
(binary "Function" read-type)
(indexed "Bound")
(indexed "Var")
(indexed "Ex")
(quantified "UnivQ" read-type)
(quantified "ExQ" read-type)
(binary "Apply" read-type)
(tagged "Named" (p.seq s.symbol read-type))
)))))
(def: (write-definition [type annotations value])
(-> Definition Code)
(` {"type" (~ (write-type type))
"annotations" (~ annotations)}))
(def: read-definition
(Syntax Definition)
(s.record ($_ p.seq
(p.after (s.this (` "type")) read-type)
(p.after (s.this (` "annotations")) s.any)
(parser/wrap []))))
(def: (write-aliases aliases)
(-> (List [Text Text]) Code)
(|> aliases (list/map (product.both code.text code.text)) code.record))
(def: read-aliases
(Syntax (List [Text Text]))
(s.record (p.some (p.seq s.text s.text))))
(def: #export (write lux-file module)
(-> Text Module Code)
(` {"lux version" (~ (code.text ///lang.version))
"lux file" (~ (code.text lux-file))
"hash" (~ (code.nat (get@ #.module-hash module)))
"aliases" (~ (write-aliases (get@ #.module-aliases module)))
"definitions" (~ (code.record (list/map (product.both code.text write-definition)
(get@ #.definitions module))))
"imports" (~ (code.tuple (list/map code.text (get@ #.imports module))))
"annotations" (~ (case (get@ #.module-annotations module)
#.None
(' "None")
(#.Some annotations)
(` ("Some" (~ annotations)))))
}))
(def: #export (read description)
(-> Code (Error [Text Module]))
(<| (s.run (list description))
(s.record (do p.Monad<Parser>
[lux-version (p.after (s.this (` "lux version")) s.text)
_ (p.assert (Invalid-Lux-Version
(format "Expected: " ///lang.version "\n"
" Actual: " lux-version "\n"))
(text/= ///lang.version lux-version))]
($_ p.seq
(p.after (s.this (` "lux file")) s.text)
($_ p.seq
(p.after (s.this (` "hash")) s.nat)
(p.after (s.this (` "aliases")) read-aliases)
(p.after (s.this (` "definitions")) (s.record (p.some (p.seq s.text read-definition))))
(p.after (s.this (` "imports")) (s.tuple (p.some s.text)))
(parser/wrap (list))
(parser/wrap (list))
(p.after (s.this (` "annotations")) (p.alt (s.this (` "None"))
(s.form (p.after (s.this (` "Some"))
s.any))))
(parser/wrap #.Cached)))))))
|
