From e0f63b0cfda4d7dd0d233d13ce88b5da889dea02 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 31 Oct 2017 01:53:56 -0400
Subject: - Now, all special forms are handled as procedures. - "lux case" now
 takes its branches as a non-empty record.

---
 new-luxc/source/luxc/analyser.lux                  |  51 +----------
 new-luxc/source/luxc/analyser/procedure.lux        |   6 +-
 new-luxc/source/luxc/analyser/procedure/common.lux | 102 +++++++++++++++++----
 .../source/luxc/analyser/procedure/host.jvm.lux    |  38 ++++----
 4 files changed, 110 insertions(+), 87 deletions(-)

(limited to 'new-luxc/source/luxc')

diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux
index f0712794d..04d8d58b7 100644
--- a/new-luxc/source/luxc/analyser.lux
+++ b/new-luxc/source/luxc/analyser.lux
@@ -8,7 +8,7 @@
        [meta]
        (meta [type]
              (type ["tc" check]))
-       [host #+ do-to])
+       [host])
   (luxc ["&" base]
         [";L" host]
         (lang ["la" analysis])
@@ -18,9 +18,7 @@
      ["&&;" function]
      ["&&;" primitive]
      ["&&;" reference]
-     ["&&;" type]
      ["&&;" structure]
-     ["&&;" case]
      ["&&;" procedure]))
 
 (for {"JVM" (as-is (host;import java.lang.reflect.Method
@@ -53,20 +51,7 @@
       })
 
 (exception: #export Macro-Expression-Must-Have-Single-Expansion)
-
-(def: (to-branches raw)
-  (-> (List Code) (Meta (List [Code Code])))
-  (case raw
-    (^ (list))
-    (:: meta;Monad<Meta> wrap (list))
-
-    (^ (list& patternH bodyH inputT))
-    (do meta;Monad<Meta>
-      [outputT (to-branches inputT)]
-      (wrap (list& [patternH bodyH] outputT)))
-
-    _
-    (&;fail "Uneven expressions for pattern-matching.")))
+(exception: #export Unrecognized-Syntax)
 
 (def: #export (analyser eval)
   (-> &;Eval &;Analyser)
@@ -105,36 +90,8 @@
                (#;Symbol reference)
                (&&reference;analyse-reference reference)
 
-               (^ (#;Form (list [_ (#;Text "lux function")]
-                                [_ (#;Symbol ["" func-name])]
-                                [_ (#;Symbol ["" arg-name])]
-                                body)))
-               (&&function;analyse-function analyse func-name arg-name body)
-
-               (^template [<special> <analyser>]
-                 (^ (#;Form (list [_ (#;Text <special>)] type value)))
-                 (<analyser> analyse eval type value))
-               (["lux check" &&type;analyse-check]
-                ["lux coerce" &&type;analyse-coerce])
-
-               (^ (#;Form (list [_ (#;Text "lux check type")] valueC)))
-               (do meta;Monad<Meta>
-                 [valueA (&;with-expected-type Type
-                           (analyse valueC))
-                  expected meta;expected-type
-                  _ (&;with-type-env
-                      (tc;check expected Type))]
-                 (wrap valueA))
-               
-               (^ (#;Form (list& [_ (#;Text "lux case")]
-                                 input
-                                 branches)))
-               (do meta;Monad<Meta>
-                 [paired (to-branches branches)]
-                 (&&case;analyse-case analyse input paired))
-
                (^ (#;Form (list& [_ (#;Text proc-name)] proc-args)))
-               (&&procedure;analyse-procedure analyse proc-name proc-args)
+               (&&procedure;analyse-procedure analyse eval proc-name proc-args)
 
                (^template [<tag> <analyser>]
                  (^ (#;Form (list& [_ (<tag> tag)]
@@ -180,5 +137,5 @@
                    (&&function;analyse-apply analyse funcT =func args)))
 
                _
-               (&;fail (format "Unrecognized syntax: " (%code ast)))
+               (&;throw Unrecognized-Syntax (%code ast))
                )))))))
diff --git a/new-luxc/source/luxc/analyser/procedure.lux b/new-luxc/source/luxc/analyser/procedure.lux
index 53ad8276c..225fb7b23 100644
--- a/new-luxc/source/luxc/analyser/procedure.lux
+++ b/new-luxc/source/luxc/analyser/procedure.lux
@@ -15,9 +15,9 @@
   (|> ./common;procedures
       (dict;merge ./host;procedures)))
 
-(def: #export (analyse-procedure analyse proc-name proc-args)
-  (-> &;Analyser Text (List Code) (Meta la;Analysis))
+(def: #export (analyse-procedure analyse eval proc-name proc-args)
+  (-> &;Analyser &;Eval Text (List Code) (Meta la;Analysis))
   (<| (maybe;default (&;fail (format "Unknown procedure: " (%t proc-name))))
       (do maybe;Monad<Maybe>
         [proc (dict;get proc-name procedures)]
-        (wrap (proc analyse proc-args)))))
+        (wrap (proc analyse eval proc-args)))))
diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux
index 6c2e810b5..f64c537cb 100644
--- a/new-luxc/source/luxc/analyser/procedure/common.lux
+++ b/new-luxc/source/luxc/analyser/procedure/common.lux
@@ -12,11 +12,14 @@
        [io])
   (luxc ["&" base]
         (lang ["la" analysis])
-        (analyser ["&;" common])))
+        (analyser ["&;" common]
+                  [";A" function]
+                  [";A" case]
+                  [";A" type])))
 
 ## [Utils]
 (type: #export Proc
-  (-> &;Analyser (List Code) (Meta la;Analysis)))
+  (-> &;Analyser &;Eval (List Code) (Meta la;Analysis)))
 
 (type: #export Bundle
   (Dict Text Proc))
@@ -42,7 +45,7 @@
 (def: (simple proc input-types output-type)
   (-> Text (List Type) Type Proc)
   (let [num-expected (list;size input-types)]
-    (function [analyse args]
+    (function [analyse eval args]
       (let [num-actual (list;size args)]
         (if (n.= num-expected num-actual)
           (do Monad<Meta>
@@ -77,17 +80,17 @@
 ## "lux is" represents reference/pointer equality.
 (def: (lux-is proc)
   (-> Text Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         ((binary varT varT Bool proc)
-         analyse args)))))
+         analyse eval args)))))
 
 ## "lux try" provides a simple way to interact with the host platform's
 ## error-handling facilities.
 (def: (lux-try proc)
   (-> Text Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         (case args
@@ -105,11 +108,74 @@
           _
           (&;fail (wrong-arity proc +1 (list;size args))))))))
 
+(def: (lux//function proc)
+  (-> Text Proc)
+  (function [analyse eval args]
+    (&common;with-var
+      (function [[var-id varT]]
+        (case args
+          (^ (list [_ (#;Symbol ["" func-name])]
+                   [_ (#;Symbol ["" arg-name])]
+                   body))
+          (functionA;analyse-function analyse func-name arg-name body)
+          
+          _
+          (&;fail (wrong-arity proc +3 (list;size args))))))))
+
+(def: (lux//case proc)
+  (-> Text Proc)
+  (function [analyse eval args]
+    (&common;with-var
+      (function [[var-id varT]]
+        (case args
+          (^ (list input [_ (#;Record branches)]))
+          (caseA;analyse-case analyse input branches)
+          
+          _
+          (&;fail (wrong-arity proc +2 (list;size args))))))))
+
+(do-template [<name> <analyser>]
+  [(def: (<name> proc)
+     (-> Text Proc)
+     (function [analyse eval args]
+       (&common;with-var
+         (function [[var-id varT]]
+           (case args
+             (^ (list typeC valueC))
+             (<analyser> analyse eval typeC valueC)
+             
+             _
+             (&;fail (wrong-arity proc +2 (list;size args))))))))]
+
+  [lux//check typeA;analyse-check]
+  [lux//coerce typeA;analyse-coerce])
+
+(def: (lux//check//type proc)
+  (-> Text Proc)
+  (function [analyse eval args]
+    (case args
+      (^ (list valueC))
+      (do meta;Monad<Meta>
+        [valueA (&;with-expected-type Type
+                  (analyse valueC))
+         expected meta;expected-type
+         _ (&;with-type-env
+             (tc;check expected Type))]
+        (wrap valueA))
+      
+      _
+      (&;fail (wrong-arity proc +1 (list;size args))))))
+
 (def: lux-procs
   Bundle
   (|> (dict;new text;Hash<Text>)
       (install "is" lux-is)
-      (install "try" lux-try)))
+      (install "try" lux-try)
+      (install "function" lux//function)
+      (install "case" lux//case)
+      (install "check" lux//check)
+      (install "coerce" lux//coerce)
+      (install "check type" lux//check//type)))
 
 (def: io-procs
   Bundle
@@ -222,27 +288,27 @@
 
 (def: (array-get proc)
   (-> Text Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         ((binary Nat (type (Array varT)) varT proc)
-         analyse args)))))
+         analyse eval args)))))
 
 (def: (array-put proc)
   (-> Text Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc)
-         analyse args)))))
+         analyse eval args)))))
 
 (def: (array-remove proc)
   (-> Text Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         ((binary Nat (type (Array varT)) (type (Array varT)) proc)
-         analyse args)))))
+         analyse eval args)))))
 
 (def: array-procs
   Bundle
@@ -281,7 +347,7 @@
 
 (def: (atom-new proc)
   (-> Text Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         (case args
@@ -301,19 +367,19 @@
 
 (def: (atom-read proc)
   (-> Text Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         ((unary (type (A;Atom varT)) varT proc)
-         analyse args)))))
+         analyse eval args)))))
 
 (def: (atom-compare-and-swap proc)
   (-> Text Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         ((trinary varT varT (type (A;Atom varT)) Bool proc)
-         analyse args)))))
+         analyse eval args)))))
 
 (def: atom-procs
   Bundle
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index 84592d4ee..4db7b4dda 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -147,7 +147,7 @@
 
 (def: (array-length proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         (case args
@@ -167,7 +167,7 @@
 
 (def: (array-new proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (case args
       (^ (list lengthC))
       (do meta;Monad<Meta>
@@ -261,7 +261,7 @@
 
 (def: (array-read proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         (case args
@@ -282,7 +282,7 @@
 
 (def: (array-write proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         (case args
@@ -315,7 +315,7 @@
 
 (def: (object-null proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (case args
       (^ (list))
       (do meta;Monad<Meta>
@@ -328,7 +328,7 @@
 
 (def: (object-null? proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         (case args
@@ -347,7 +347,7 @@
 
 (def: (object-synchronized proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         (case args
@@ -448,7 +448,7 @@
 
 (def: (object-throw proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         (case args
@@ -472,7 +472,7 @@
 
 (def: (object-class proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (case args
       (^ (list classC))
       (case classC
@@ -492,7 +492,7 @@
 
 (def: (object-instance? proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (&common;with-var
       (function [[var-id varT]]
         (case args
@@ -793,7 +793,7 @@
 
 (def: (static-get proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (case args
       (^ (list classC fieldC))
       (case [classC fieldC]
@@ -811,7 +811,7 @@
 
 (def: (static-put proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (case args
       (^ (list classC fieldC valueC))
       (case [classC fieldC]
@@ -834,7 +834,7 @@
 
 (def: (virtual-get proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (case args
       (^ (list classC fieldC objectC))
       (case [classC fieldC]
@@ -853,7 +853,7 @@
 
 (def: (virtual-put proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (case args
       (^ (list classC fieldC valueC objectC))
       (case [classC fieldC]
@@ -1104,7 +1104,7 @@
 
 (def: (invoke//static proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (case (: (e;Error [Text Text (List [Text Code])])
              (s;run args ($_ p;seq s;text s;text (p;some (s;tuple (p;seq s;text s;any))))))
       (#e;Success [class method argsTC])
@@ -1121,7 +1121,7 @@
 
 (def: (invoke//virtual proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (case (: (e;Error [Text Text Code (List [Text Code])])
              (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))))))
       (#e;Success [class method objectC argsTC])
@@ -1144,7 +1144,7 @@
 
 (def: (invoke//special proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (case (: (e;Error [(List Code) [Text Text Code (List [Text Code]) Unit]])
              (p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!)))
       (#e;Success [_ [class method objectC argsTC _]])
@@ -1163,7 +1163,7 @@
 
 (def: (invoke//interface proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (case (: (e;Error [Text Text Code (List [Text Code])])
              (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))))))
       (#e;Success [class-name method objectC argsTC])
@@ -1183,7 +1183,7 @@
 
 (def: (invoke//constructor proc)
   (-> Text @;Proc)
-  (function [analyse args]
+  (function [analyse eval args]
     (case (: (e;Error [Text (List [Text Code])])
              (s;run args ($_ p;seq s;text (p;some (s;tuple (p;seq s;text s;any))))))
       (#e;Success [class argsTC])
-- 
cgit v1.2.3