diff options
author | Eduardo Julian | 2017-12-05 02:41:59 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-12-05 02:41:59 -0400 |
commit | 7e18f589a05bde28b3f710d92f72b7bd6b6e144f (patch) | |
tree | cea41a63fa361d82300e52720f1d96da89312b52 /new-luxc/source/luxc/lang/extension/statement.lux | |
parent | 9641cfa9ed5043f3df2792f5aeab4e42b2f79a44 (diff) |
- Added analysis, synthesis, translation and statement extensions.
- No longer doing ad-hoc I/O in new-luxc.
- Minor fixes and adjustments.
Diffstat (limited to 'new-luxc/source/luxc/lang/extension/statement.lux')
-rw-r--r-- | new-luxc/source/luxc/lang/extension/statement.lux | 146 |
1 files changed, 146 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/extension/statement.lux b/new-luxc/source/luxc/lang/extension/statement.lux new file mode 100644 index 000000000..6e9530f38 --- /dev/null +++ b/new-luxc/source/luxc/lang/extension/statement.lux @@ -0,0 +1,146 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [text] + text/format + (coll [list "list/" Functor<List>] + [dict #+ Dict])) + [macro] + (lang (type ["tc" check])) + [io #+ IO]) + [//] + (luxc [lang] + (lang [".L" host] + (host ["$" jvm]) + (analysis [".A" common] + [".A" expression]) + (synthesis [".S" expression]) + (translation [".T" expression] + [".T" statement] + [".T" eval]) + [".L" eval]))) + +(exception: #export Invalid-Statement) +(exception: #export 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 annsC) + (-> 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 annsA)) + annsV (evalT.eval annsI)] + (wrap [annsI (:! Code annsV)]))) + +(def: (ensure-valid-alias def-name annotations value) + (-> Text Code Code (Meta Unit)) + (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> + [[annotationsI annotationsV] (process-annotations 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 Void id annotationsI 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 valueA)) + _ (lang.with-scope + (statementT.translate-def def-name valueT valueI annotationsI 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 + (lang.with-type (type (IO Unit)) + (expressionA.analyser evalL.eval programC))) + programI (expressionT.translate (expressionS.synthesize programA)) + _ (statementT.translate-program args 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))) + valueI (expressionT.translate (expressionS.synthesize valueA)) + valueV (evalT.eval valueI) + _ (<installer> name (:! <type> valueV))] + (wrap [])) + + _ + (throw-invalid-statement procedure inputsC+))))] + + [lux//analysis //.Expression //.install-analysis] + [lux//synthesis //.Expression //.install-synthesis] + [lux//translation //.Expression //.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] + ))))) |