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/procedure/common.lux | 102 +++++++++++++++++----
 .../source/luxc/analyser/procedure/host.jvm.lux    |  38 ++++----
 2 files changed, 103 insertions(+), 37 deletions(-)

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

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