aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/extension
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang/extension')
-rw-r--r--new-luxc/source/luxc/lang/extension/analysis.lux9
-rw-r--r--new-luxc/source/luxc/lang/extension/statement.lux146
-rw-r--r--new-luxc/source/luxc/lang/extension/synthesis.lux9
-rw-r--r--new-luxc/source/luxc/lang/extension/translation.lux9
4 files changed, 173 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/extension/analysis.lux b/new-luxc/source/luxc/lang/extension/analysis.lux
new file mode 100644
index 000000000..d034f2919
--- /dev/null
+++ b/new-luxc/source/luxc/lang/extension/analysis.lux
@@ -0,0 +1,9 @@
+(.module:
+ lux
+ (lux (data [text]
+ (coll [dict #+ Dict])))
+ [//])
+
+(def: #export defaults
+ (Dict Text //.Expression)
+ (dict.new text.Hash<Text>))
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]
+ )))))
diff --git a/new-luxc/source/luxc/lang/extension/synthesis.lux b/new-luxc/source/luxc/lang/extension/synthesis.lux
new file mode 100644
index 000000000..d034f2919
--- /dev/null
+++ b/new-luxc/source/luxc/lang/extension/synthesis.lux
@@ -0,0 +1,9 @@
+(.module:
+ lux
+ (lux (data [text]
+ (coll [dict #+ Dict])))
+ [//])
+
+(def: #export defaults
+ (Dict Text //.Expression)
+ (dict.new text.Hash<Text>))
diff --git a/new-luxc/source/luxc/lang/extension/translation.lux b/new-luxc/source/luxc/lang/extension/translation.lux
new file mode 100644
index 000000000..d034f2919
--- /dev/null
+++ b/new-luxc/source/luxc/lang/extension/translation.lux
@@ -0,0 +1,9 @@
+(.module:
+ lux
+ (lux (data [text]
+ (coll [dict #+ Dict])))
+ [//])
+
+(def: #export defaults
+ (Dict Text //.Expression)
+ (dict.new text.Hash<Text>))