From 7e18f589a05bde28b3f710d92f72b7bd6b6e144f Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 5 Dec 2017 02:41:59 -0400
Subject: - Added analysis, synthesis, translation and statement extensions. -
 No longer doing ad-hoc I/O in new-luxc. - Minor fixes and adjustments.

---
 new-luxc/source/luxc/lang/extension/statement.lux | 146 ++++++++++++++++++++++
 1 file changed, 146 insertions(+)
 create mode 100644 new-luxc/source/luxc/lang/extension/statement.lux

(limited to 'new-luxc/source/luxc/lang/extension/statement.lux')

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]
+                )))))
-- 
cgit v1.2.3