blob: a9299563042580e284a089141258fbca806ef944 (
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
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
(.module:
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:])
(data [text]
text/format
(coll [list "list/" Functor<List>]
(dictionary ["dict" unordered #+ Dict])))
[macro]
(lang (type ["tc" check]))
[io #+ IO])
[// #+ Syntheses]
(luxc [lang]
(lang [".L" host]
[".L" scope]
(host ["$" jvm])
(analysis [".A" common]
[".A" expression])
(synthesis [".S" expression])
(translation (jvm [".T" expression]
[".T" statement]
[".T" eval]))
[".L" eval])))
(do-template [<name>]
[(exception: #export (<name> {message Text})
message)]
[Invalid-Statement]
[Invalid-Alias]
)
(def: (throw-invalid-statement procedure inputsC+)
(All [a] (-> Text (List Code) (Meta a)))
(lang.throw Invalid-Statement
(format "Statement: " procedure "\n"
" Inputs:"
(|> inputsC+
list.enumerate
(list/map (function (_ [idx inputC])
(format "\n " (%n idx) " " (%code inputC))))
(text.join-with "")) "\n")))
(def: (process-annotations syntheses annsC)
(-> Syntheses Code (Meta [$.Inst Code]))
(do macro.Monad<Meta>
[[_ annsA] (lang.with-scope
(lang.with-type Code
(expressionA.analyser evalL.eval annsC)))
annsI (expressionT.translate (expressionS.synthesize syntheses annsA))
annsV (evalT.eval annsI)]
(wrap [annsI (:! Code annsV)])))
(def: (ensure-valid-alias def-name annotations value)
(-> Text Code Code (Meta Any))
(case [annotations value]
(^multi [[_ (#.Record pairs)] [_ (#.Symbol _)]]
(|> pairs list.size (n/= +1)))
(:: macro.Monad<Meta> wrap [])
_
(lang.throw Invalid-Alias def-name)))
(def: (lux//def procedure)
(-> Text //.Statement)
(function (_ inputsC+)
(case inputsC+
(^ (list [_ (#.Symbol ["" def-name])] valueC annotationsC))
(hostL.with-context def-name
(lang.with-fresh-type-env
(do macro.Monad<Meta>
[syntheses //.all-syntheses
[annotationsI annotationsV] (process-annotations syntheses annotationsC)]
(case (macro.get-symbol-ann (ident-for #.alias) annotationsV)
(#.Some real-def)
(do @
[_ (ensure-valid-alias def-name annotationsV valueC)
_ (lang.with-scope
(statementT.translate-def def-name Nothing id annotationsV))]
(wrap []))
#.None
(do @
[[_ valueT valueA] (lang.with-scope
(if (macro.type? (:! Code annotationsV))
(do @
[valueA (lang.with-type Type
(expressionA.analyser evalL.eval valueC))]
(wrap [Type valueA]))
(commonA.with-unknown-type
(expressionA.analyser evalL.eval valueC))))
valueT (lang.with-type-env
(tc.clean valueT))
valueI (expressionT.translate (expressionS.synthesize syntheses valueA))
_ (lang.with-scope
(statementT.translate-def def-name valueT valueI annotationsV))]
(wrap []))))))
_
(throw-invalid-statement procedure inputsC+))))
(def: (lux//program procedure)
(-> Text //.Statement)
(function (_ inputsC+)
(case inputsC+
(^ (list [_ (#.Symbol ["" args])] programC))
(do macro.Monad<Meta>
[[_ programA] (<| lang.with-scope
(scopeL.with-local [args (type (List Text))])
(lang.with-type (type (IO Any)))
(expressionA.analyser evalL.eval programC))
syntheses //.all-syntheses
programI (expressionT.translate (expressionS.synthesize syntheses programA))
_ (statementT.translate-program programI)]
(wrap []))
_
(throw-invalid-statement procedure inputsC+))))
(do-template [<mame> <type> <installer>]
[(def: (<mame> procedure)
(-> Text //.Statement)
(function (_ inputsC+)
(case inputsC+
(^ (list [_ (#.Text name)] valueC))
(do macro.Monad<Meta>
[[_ valueA] (lang.with-scope
(lang.with-type <type>
(expressionA.analyser evalL.eval valueC)))
syntheses //.all-syntheses
valueI (expressionT.translate (expressionS.synthesize syntheses valueA))
valueV (evalT.eval valueI)
_ (<installer> name (:! <type> valueV))]
(wrap []))
_
(throw-invalid-statement procedure inputsC+))))]
[lux//analysis //.Analysis //.install-analysis]
[lux//synthesis //.Synthesis //.install-synthesis]
[lux//translation //.Translation //.install-translation]
[lux//statement //.Statement //.install-statement])
(def: #export defaults
(Dict Text //.Statement)
(`` (|> (dict.new text.Hash<Text>)
(~~ (do-template [<name> <extension>]
[(dict.put <name> (<extension> <name>))]
["lux def" lux//def]
["lux program" lux//program]
["lux analysis" lux//analysis]
["lux synthesis" lux//synthesis]
["lux translation" lux//translation]
["lux statement" lux//statement]
)))))
|
