From 15121222d570f8fe3c5a326208e4f0bad737e63c Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 31 Oct 2017 23:39:49 -0400
Subject: - Re-organized analysis.

---
 new-luxc/source/luxc/lang/analysis/expression.lux | 141 ++++++++++++++++++++++
 1 file changed, 141 insertions(+)
 create mode 100644 new-luxc/source/luxc/lang/analysis/expression.lux

(limited to 'new-luxc/source/luxc/lang/analysis/expression.lux')

diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux
new file mode 100644
index 000000000..e3a623089
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/expression.lux
@@ -0,0 +1,141 @@
+(;module:
+  lux
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:])
+       (data ["e" error]
+             [product]
+             text/format)
+       [meta]
+       (meta [type]
+             (type ["tc" check]))
+       [host])
+  (luxc ["&" base]
+        [";L" host]
+        (lang ["la" analysis])
+        ["&;" module]
+        (generator [";G" common]))
+  (.. [";A" common]
+      [";A" function]
+      [";A" primitive]
+      [";A" reference]
+      [";A" structure]
+      [";A" procedure]))
+
+(for {"JVM" (as-is (host;import java.lang.reflect.Method
+                     (invoke [Object (Array Object)] #try Object))
+                   (host;import (java.lang.Class c)
+                     (getMethod [String (Array (Class Object))] #try Method))
+                   (host;import java.lang.Object
+                     (getClass [] (Class Object))
+                     (toString [] String))
+                   (def: _object-class (Class Object) (host;class-for Object))
+                   (def: _apply-args
+                     (Array (Class Object))
+                     (|> (host;array (Class Object) +2)
+                         (host;array-write +0 _object-class)
+                         (host;array-write +1 _object-class)))
+                   (def: (call-macro macro inputs)
+                     (-> Macro (List Code) (Meta (List Code)))
+                     (do meta;Monad<Meta>
+                       [class (commonG;load-class hostL;function-class)]
+                       (function [compiler]
+                         (do e;Monad<Error>
+                           [apply-method (Class.getMethod ["apply" _apply-args] class)
+                            output (Method.invoke [(:! Object macro)
+                                                   (|> (host;array Object +2)
+                                                       (host;array-write +0 (:! Object inputs))
+                                                       (host;array-write +1 (:! Object compiler)))]
+                                                  apply-method)]
+                           (:! (e;Error [Compiler (List Code)])
+                               output))))))
+      })
+
+(exception: #export Macro-Expression-Must-Have-Single-Expansion)
+(exception: #export Unrecognized-Syntax)
+
+(def: #export (analyser eval)
+  (-> &;Eval &;Analyser)
+  (: (-> Code (Meta la;Analysis))
+     (function analyse [ast]
+       (do meta;Monad<Meta>
+         [expectedT meta;expected-type]
+         (let [[cursor ast'] ast]
+           ## The cursor must be set in the compiler for the sake
+           ## of having useful error messages.
+           (&;with-cursor cursor
+             (case ast'
+               (^template [<tag> <analyser>]
+                 (<tag> value)
+                 (<analyser> value))
+               ([#;Bool primitiveA;analyse-bool]
+                [#;Nat  primitiveA;analyse-nat]
+                [#;Int  primitiveA;analyse-int]
+                [#;Deg  primitiveA;analyse-deg]
+                [#;Frac primitiveA;analyse-frac]
+                [#;Text primitiveA;analyse-text])
+
+               (^ (#;Tuple (list)))
+               primitiveA;analyse-unit
+
+               ## Singleton tuples are equivalent to the element they contain.
+               (^ (#;Tuple (list singleton)))
+               (analyse singleton)
+
+               (^ (#;Tuple elems))
+               (structureA;analyse-product analyse elems)
+
+               (^ (#;Record pairs))
+               (structureA;analyse-record analyse pairs)
+
+               (#;Symbol reference)
+               (referenceA;analyse-reference reference)
+
+               (^ (#;Form (list& [_ (#;Text proc-name)] proc-args)))
+               (procedureA;analyse-procedure analyse eval proc-name proc-args)
+
+               (^template [<tag> <analyser>]
+                 (^ (#;Form (list& [_ (<tag> tag)]
+                                   values)))
+                 (case values
+                   (#;Cons value #;Nil)
+                   (<analyser> analyse tag value)
+
+                   _
+                   (<analyser> analyse tag (` [(~@ values)]))))
+               ([#;Nat structureA;analyse-sum]
+                [#;Tag structureA;analyse-tagged-sum])
+
+               (#;Tag tag)
+               (structureA;analyse-tagged-sum analyse tag (' []))
+               
+               (^ (#;Form (list& func args)))
+               (do meta;Monad<Meta>
+                 [[funcT =func] (commonA;with-unknown-type
+                                  (analyse func))]
+                 (case =func
+                   [_ (#;Symbol def-name)]
+                   (do @
+                     [[def-type def-anns def-value] (meta;find-def def-name)]
+                     (if (meta;macro? def-anns)
+                       (do @
+                         [expansion (function [compiler]
+                                      (case (call-macro (:! Macro def-value) args compiler)
+                                        (#e;Success [compiler' output])
+                                        (#e;Success [compiler' output])
+
+                                        (#e;Error error)
+                                        ((&;fail error) compiler)))]
+                         (case expansion
+                           (^ (list single))
+                           (analyse single)
+
+                           _
+                           (&;throw Macro-Expression-Must-Have-Single-Expansion (%code ast))))
+                       (functionA;analyse-apply analyse funcT =func args)))
+
+                   _
+                   (functionA;analyse-apply analyse funcT =func args)))
+
+               _
+               (&;throw Unrecognized-Syntax (%code ast))
+               )))))))
-- 
cgit v1.2.3