Introduced named types (#NamedT Ident Type).

5 files changed, 239 insertions, 198 deletions

diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 7810c415b..3b6a93005 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -532,7 +532,7 @@
       (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state)
                (catch Error e
                  (prn e)
-                 (assert false (prn-str 'analyse-basic-ast (&/show-ast ?token)))))
+                 (assert false (prn-str 'analyse-basic-ast (&/show-ast token)))))
         (&/$Right state* output)
         (return* state* output)
 
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 395ae6976..483002adc 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -113,6 +113,9 @@
                                      (fail "##9##")))]
       (adjust-type* up type*))
 
+    (&/$NamedT ?name ?type)
+    (adjust-type* up ?type)
+
     _
     (assert false (prn 'adjust-type* (&type/show-type type)))
     ))
@@ -202,7 +205,7 @@
           (fail "[Pattern-matching Error] Record requires record-type.")))
 
       (&/$TagS ?ident)
-      (|do [;; :let [_ (println "#00")]
+      (|do [;; :let [_ (println "#00" (&/ident->text ?ident))]
             [=module =name] (&&/resolved-ident ?ident)
             ;; :let [_ (println "#01")]
             value-type* (adjust-type value-type)
@@ -219,7 +222,7 @@
 
       (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident))
                          ?values))
-      (|do [;; :let [_ (println "#10" ?ident)]
+      (|do [;; :let [_ (println "#10" (&/ident->text ?ident))]
             [=module =name] (&&/resolved-ident ?ident)
             ;; :let [_ (println "#11")]
             value-type* (adjust-type value-type)
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 79b804088..8a79e0494 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -401,6 +401,7 @@
   ;; (when (= "PList/Dict" ?name)
   ;;   (prn 'DEF ?name (&/show-ast ?value)))
   (|do [module-name &/get-module-name
+        ;; :let [_ (println 'DEF/PRE (str module-name ";" ?name))]
         ? (&&module/defined? module-name ?name)]
     (if ?
       (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name)))
@@ -416,15 +417,20 @@
             (return (&/|list)))
 
           _
-          (do (println 'DEF (str module-name ";" ?name))
+          (do ;; (println 'DEF (str module-name ";" ?name))
             (|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))
-                  :let [_ (println 'DEF/COMPILED (str module-name ";" ?name))]]
+                  :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name))
+                        _ (println 'DEF (str module-name ";" ?name))]]
               (return (&/|list)))))
         ))))
 
 (defn analyse-declare-macro [analyse compile-token ?name]
-  (|do [module-name &/get-module-name
-        _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))]
+  (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")]
+        module-name &/get-module-name
+        ;; :let [_ (prn 'analyse-declare-macro ?name "1")]
+        _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))
+        ;; :let [_ (prn 'analyse-declare-macro ?name "2")]
+        ]
     (return (&/|list))))
 
 (defn ensure-undeclared-tags [module tags]
diff --git a/src/lux/base.clj b/src/lux/base.clj
index e39f76409..44875d1df 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -58,7 +58,8 @@
   "VarT"
   "ExT"
   "AllT"
-  "AppT")
+  "AppT"
+  "NamedT")
 
 ;; [Fields]
 ;; Binding
@@ -229,7 +230,7 @@
 (defn |head [xs]
   (|case xs
     ($Nil)
-    (assert false)
+    (assert false (prn-str '|head))
 
     ($Cons x _)
     x))
@@ -237,7 +238,7 @@
 (defn |tail [xs]
   (|case xs
     ($Nil)
-    (assert false)
+    (assert false (prn-str '|tail))
 
     ($Cons _ xs*)
     xs*))
@@ -787,9 +788,8 @@
     ($Meta _ ($FormS ?elems))
     (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")")
 
-    ;; _
-    ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0)))
-    ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0)))
+    _
+    (assert false (prn-str 'show-ast (adt->text ast)))
     ))
 
 (defn ident->text [ident]
@@ -898,19 +898,6 @@
     (and (= xmodule ymodule)
          (= xname yname))))
 
-;; (defn |list-put [idx val xs]
-;;   (|case [idx xs]
-;;     [_ ($Nil)]
-;;     (V $None nil)
-    
-;;     [0 ($Cons x xs*)]
-;;     (V $Some (V $Cons (T val xs*)))
-    
-;;     [_ ($Cons x xs*)]
-;;     (|case (|list-put idx val xs*)
-;;       ($None)      (V $None nil)
-;;       ($Some xs**) (V $Some (V $Cons (T x xs**))))))
-
 (defn |list-put [idx val xs]
   (|case xs
     ($Nil)
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 2516fbc1d..e78b5616a 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -26,14 +26,6 @@
     _
     false))
 
-(def Bool (&/V &/$DataT "java.lang.Boolean"))
-(def Int (&/V &/$DataT "java.lang.Long"))
-(def Real (&/V &/$DataT "java.lang.Double"))
-(def Char (&/V &/$DataT "java.lang.Character"))
-(def Text (&/V &/$DataT "java.lang.String"))
-(def Unit (&/V &/$TupleT (&/|list)))
-(def $Void (&/V &/$VariantT (&/|list)))
-
 (def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil)))
 (def ^:private no-env (&/V &/$None nil))
 (defn Data$ [name]
@@ -46,154 +38,174 @@
   (&/V &/$LambdaT (&/T in out)))
 (defn App$ [fun arg]
   (&/V &/$AppT (&/T fun arg)))
-
 (defn Tuple$ [members]
   ;; (assert (|list? members))
   (&/V &/$TupleT members))
-
 (defn Variant$ [members]
   ;; (assert (|list? members))
   (&/V &/$VariantT members))
-
 (defn All$ [env name arg body]
   (&/V &/$AllT (&/T env name arg body)))
+(defn Named$ [name type]
+  (&/V &/$NamedT (&/T name type)))
+
+
+(def Bool (Named$ (&/T "lux" "Bool") (&/V &/$DataT "java.lang.Boolean")))
+(def Int (Named$ (&/T "lux" "Int") (&/V &/$DataT "java.lang.Long")))
+(def Real (Named$ (&/T "lux" "Real") (&/V &/$DataT "java.lang.Double")))
+(def Char (Named$ (&/T "lux" "Char") (&/V &/$DataT "java.lang.Character")))
+(def Text (Named$ (&/T "lux" "Text") (&/V &/$DataT "java.lang.String")))
+(def Unit (Named$ (&/T "lux" "Unit") (&/V &/$TupleT (&/|list))))
+(def $Void (Named$ (&/T "lux" "Void") (&/V &/$VariantT (&/|list))))
+(def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text))))
 
 (def IO
-  (All$ empty-env "IO" "a"
-        (Lambda$ Unit (Bound$ "a"))))
+  (Named$ (&/T "lux/data" "IO")
+          (All$ empty-env "IO" "a"
+                (Lambda$ Unit (Bound$ "a")))))
 
 (def List
-  (All$ empty-env "lux;List" "a"
-        (Variant$ (&/|list
-                   ;; lux;Nil
-                   Unit
-                   ;; lux;Cons
-                   (Tuple$ (&/|list (Bound$ "a")
-                                    (App$ (Bound$ "lux;List")
-                                          (Bound$ "a"))))
-                   ))))
+  (Named$ (&/T "lux" "List")
+          (All$ empty-env "lux;List" "a"
+                (Variant$ (&/|list
+                           ;; lux;Nil
+                           Unit
+                           ;; lux;Cons
+                           (Tuple$ (&/|list (Bound$ "a")
+                                            (App$ (Bound$ "lux;List")
+                                                  (Bound$ "a"))))
+                           )))))
 
 (def Maybe
-  (All$ empty-env "lux;Maybe" "a"
-        (Variant$ (&/|list
-                   ;; lux;None
-                   Unit
-                   ;; lux;Some
-                   (Bound$ "a")
-                   ))))
+  (Named$ (&/T "lux" "Maybe")
+          (All$ empty-env "lux;Maybe" "a"
+                (Variant$ (&/|list
+                           ;; lux;None
+                           Unit
+                           ;; lux;Some
+                           (Bound$ "a")
+                           )))))
 
 (def Type
-  (let [Type (App$ (Bound$ "Type") (Bound$ "_"))
-        TypeList (App$ List Type)
-        TypeEnv (App$ List (Tuple$ (&/|list Text Type)))
-        TypePair (Tuple$ (&/|list Type Type))]
-    (App$ (All$ empty-env "Type" "_"
-                (Variant$ (&/|list
-                           ;; DataT
-                           Text
-                           ;; VariantT
-                           TypeList
-                           ;; TupleT
-                           TypeList
-                           ;; LambdaT
-                           TypePair
-                           ;; BoundT
-                           Text
-                           ;; VarT
-                           Int
-                           ;; ExT
-                           Int
-                           ;; AllT
-                           (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type))
-                           ;; AppT
-                           TypePair
-                           )))
-          $Void)))
+  (Named$ (&/T "lux" "Type")
+          (let [Type (App$ (Bound$ "Type") (Bound$ "_"))
+                TypeList (App$ List Type)
+                TypeEnv (App$ List (Tuple$ (&/|list Text Type)))
+                TypePair (Tuple$ (&/|list Type Type))]
+            (App$ (All$ empty-env "Type" "_"
+                        (Variant$ (&/|list
+                                   ;; DataT
+                                   Text
+                                   ;; VariantT
+                                   TypeList
+                                   ;; TupleT
+                                   TypeList
+                                   ;; LambdaT
+                                   TypePair
+                                   ;; BoundT
+                                   Text
+                                   ;; VarT
+                                   Int
+                                   ;; ExT
+                                   Int
+                                   ;; AllT
+                                   (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type))
+                                   ;; AppT
+                                   TypePair
+                                   ;; NamedT
+                                   (Tuple$ (&/|list Ident Type))
+                                   )))
+                  $Void))))
 
 (def Bindings
-  (All$ empty-env "lux;Bindings" "k"
-        (All$ no-env "" "v"
-              (Tuple$ (&/|list
-                       ;; "lux;counter"
-                       Int
-                       ;; "lux;mappings"
-                       (App$ List
-                             (Tuple$ (&/|list (Bound$ "k")
-                                              (Bound$ "v")))))))))
+  (Named$ (&/T "lux" "Bindings")
+          (All$ empty-env "lux;Bindings" "k"
+                (All$ no-env "" "v"
+                      (Tuple$ (&/|list
+                               ;; "lux;counter"
+                               Int
+                               ;; "lux;mappings"
+                               (App$ List
+                                     (Tuple$ (&/|list (Bound$ "k")
+                                                      (Bound$ "v"))))))))))
 
 (def Env
-  (let [bindings (App$ (App$ Bindings (Bound$ "k"))
-                       (Bound$ "v"))]
-    (All$ empty-env "lux;Env" "k"
-          (All$ no-env "" "v"
-                (Tuple$
-                 (&/|list
-                  ;; "lux;name"
-                  Text
-                  ;; "lux;inner-closures"
-                  Int
-                  ;; "lux;locals"
-                  bindings
-                  ;; "lux;closure"
-                  bindings
-                  ))))))
+  (Named$ (&/T "lux" "Env")
+          (let [bindings (App$ (App$ Bindings (Bound$ "k"))
+                               (Bound$ "v"))]
+            (All$ empty-env "lux;Env" "k"
+                  (All$ no-env "" "v"
+                        (Tuple$
+                         (&/|list
+                          ;; "lux;name"
+                          Text
+                          ;; "lux;inner-closures"
+                          Int
+                          ;; "lux;locals"
+                          bindings
+                          ;; "lux;closure"
+                          bindings
+                          )))))))
 
 (def Cursor
-  (Tuple$ (&/|list Text Int Int)))
+  (Named$ (&/T "lux" "Cursor")
+          (Tuple$ (&/|list Text Int Int))))
 
 (def Meta
-  (All$ empty-env "lux;Meta" "m"
-        (All$ no-env "" "v"
-              (Variant$ (&/|list
-                         ;; &/$Meta
-                         (Tuple$ (&/|list (Bound$ "m")
-                                          (Bound$ "v"))))))))
-
-(def Ident (Tuple$ (&/|list Text Text)))
+  (Named$ (&/T "lux" "Meta")
+          (All$ empty-env "lux;Meta" "m"
+                (All$ no-env "" "v"
+                      (Variant$ (&/|list
+                                 ;; &/$Meta
+                                 (Tuple$ (&/|list (Bound$ "m")
+                                                  (Bound$ "v")))))))))
 
 (def AST*
-  (let [AST* (App$ (Bound$ "w")
-                   (App$ (Bound$ "lux;AST'")
-                         (Bound$ "w")))
-        AST*List (App$ List AST*)]
-    (All$ empty-env "lux;AST'" "w"
-          (Variant$ (&/|list
-                     ;; &/$BoolS
-                     Bool
-                     ;; &/$IntS
-                     Int
-                     ;; &/$RealS
-                     Real
-                     ;; &/$CharS
-                     Char
-                     ;; &/$TextS
-                     Text
-                     ;; &/$SymbolS
-                     Ident
-                     ;; &/$TagS
-                     Ident
-                     ;; &/$FormS
-                     AST*List
-                     ;; &/$TupleS
-                     AST*List
-                     ;; &/$RecordS
-                     (App$ List (Tuple$ (&/|list AST* AST*))))
-                    ))))
+  (Named$ (&/T "lux" "AST'")
+          (let [AST* (App$ (Bound$ "w")
+                           (App$ (Bound$ "lux;AST'")
+                                 (Bound$ "w")))
+                AST*List (App$ List AST*)]
+            (All$ empty-env "lux;AST'" "w"
+                  (Variant$ (&/|list
+                             ;; &/$BoolS
+                             Bool
+                             ;; &/$IntS
+                             Int
+                             ;; &/$RealS
+                             Real
+                             ;; &/$CharS
+                             Char
+                             ;; &/$TextS
+                             Text
+                             ;; &/$SymbolS
+                             Ident
+                             ;; &/$TagS
+                             Ident
+                             ;; &/$FormS
+                             AST*List
+                             ;; &/$TupleS
+                             AST*List
+                             ;; &/$RecordS
+                             (App$ List (Tuple$ (&/|list AST* AST*))))
+                            )))))
 
 (def AST
-  (let [w (App$ Meta Cursor)]
-    (App$ w (App$ AST* w))))
+  (Named$ (&/T "lux" "AST")
+          (let [w (App$ Meta Cursor)]
+            (App$ w (App$ AST* w)))))
 
 (def ^:private ASTList (App$ List AST))
 
 (def Either
-  (All$ empty-env "lux;Either" "l"
-        (All$ no-env "" "r"
-              (Variant$ (&/|list
-                         ;; &/$Left
-                         (Bound$ "l")
-                         ;; &/$Right
-                         (Bound$ "r"))))))
+  (Named$ (&/T "lux" "Either")
+          (All$ empty-env "lux;Either" "l"
+                (All$ no-env "" "r"
+                      (Variant$ (&/|list
+                                 ;; &/$Left
+                                 (Bound$ "l")
+                                 ;; &/$Right
+                                 (Bound$ "r")))))))
 
 (def StateE
   (All$ empty-env "lux;StateE" "s"
@@ -204,19 +216,21 @@
                                               (Bound$ "a"))))))))
 
 (def Source
-  (App$ List
-        (App$ (App$ Meta Cursor)
-              Text)))
+  (Named$ (&/T "lux" "Source")
+          (App$ List
+                (App$ (App$ Meta Cursor)
+                      Text))))
 
 (def Host
-  (Tuple$
-   (&/|list
-    ;; "lux;writer"
-    (Data$ "org.objectweb.asm.ClassWriter")
-    ;; "lux;loader"
-    (Data$ "java.lang.ClassLoader")
-    ;; "lux;classes"
-    (Data$ "clojure.lang.Atom"))))
+  (Named$ (&/T "lux" "Host")
+          (Tuple$
+           (&/|list
+            ;; "lux;writer"
+            (Data$ "org.objectweb.asm.ClassWriter")
+            ;; "lux;loader"
+            (Data$ "java.lang.ClassLoader")
+            ;; "lux;classes"
+            (Data$ "clojure.lang.Atom")))))
 
 (def DefData*
   (All$ empty-env "lux;DefData'" ""
@@ -232,11 +246,12 @@
                    ))))
 
 (def LuxVar
-  (Variant$ (&/|list
-             ;; "lux;Local"
-             Int
-             ;; "lux;Global"
-             Ident)))
+  (Named$ (&/T "lux" "LuxVar")
+          (Variant$ (&/|list
+                     ;; "lux;Local"
+                     Int
+                     ;; "lux;Global"
+                     Ident))))
 
 (def $Module
   (All$ empty-env "lux;$Module" "Compiler"
@@ -264,37 +279,39 @@
           ))))
 
 (def $Compiler
-  (App$ (All$ empty-env "lux;Compiler" ""
-              (Tuple$
-               (&/|list
-                ;; "lux;source"
-                Source
-                ;; "lux;cursor"
-                Cursor
-                ;; "lux;modules"
-                (App$ List (Tuple$ (&/|list Text
-                                            (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ ""))))))
-                ;; "lux;envs"
-                (App$ List
-                      (App$ (App$ Env Text)
-                            (Tuple$ (&/|list LuxVar Type))))
-                ;; "lux;types"
-                (App$ (App$ Bindings Int) Type)
-                ;; "lux;expected"
-                Type
-                ;; "lux;seed"
-                Int
-                ;; "lux;eval?"
-                Bool
-                ;; "lux;host"
-                Host
-                )))
-        $Void))
+  (Named$ (&/T "lux" "Compiler")
+          (App$ (All$ empty-env "lux;Compiler" ""
+                      (Tuple$
+                       (&/|list
+                        ;; "lux;source"
+                        Source
+                        ;; "lux;cursor"
+                        Cursor
+                        ;; "lux;modules"
+                        (App$ List (Tuple$ (&/|list Text
+                                                    (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ ""))))))
+                        ;; "lux;envs"
+                        (App$ List
+                              (App$ (App$ Env Text)
+                                    (Tuple$ (&/|list LuxVar Type))))
+                        ;; "lux;types"
+                        (App$ (App$ Bindings Int) Type)
+                        ;; "lux;expected"
+                        Type
+                        ;; "lux;seed"
+                        Int
+                        ;; "lux;eval?"
+                        Bool
+                        ;; "lux;host"
+                        Host
+                        )))
+                $Void)))
 
 (def Macro
-  (Lambda$ ASTList
-           (App$ (App$ StateE $Compiler)
-                 ASTList)))
+  (Named$ (&/T "lux" "Macro")
+          (Lambda$ ASTList
+                   (App$ (App$ StateE $Compiler)
+                         ASTList))))
 
 (defn bound? [id]
   (fn [state]
@@ -512,8 +529,11 @@
         (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")"))
       ?name)
 
+    (&/$NamedT ?name ?type)
+    (&/ident->text ?name)
+
     _
-    (assert false (prn-str 'show-type (aget type 0)))))
+    (assert false (prn-str 'show-type (&/adt->text type)))))
 
 (defn type= [x y]
   (or (clojure.lang.Util/identical x y)
@@ -566,6 +586,12 @@
                           (type= xbody ybody)
                           )
 
+                     [(&/$NamedT ?xname ?xtype) _]
+                     (type= ?xtype y)
+
+                     [_ (&/$NamedT ?yname ?ytype)]
+                     (type= x ?ytype)
+                     
                      [_ _]
                      false
                      )]
@@ -640,9 +666,12 @@
     (&/$AppT F A)
     (|do [type-fn* (apply-type F A)]
       (apply-type type-fn* param))
+
+    (&/$NamedT ?name ?type)
+    (apply-type ?type param)
     
     _
-    (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n"))))
+    (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n"))))
 
 (defn as-obj [class]
   (case class
@@ -805,7 +834,7 @@
                                                           (show-type a)))))
                                          (&/|interpose "\n\n")
                                          (&/fold str "")))
-                (assert false))]
+                (assert false (prn-str 'check* '[(&/$AppT F A) _] (&/|length fixpoints) (show-type expected) (show-type actual))))]
         (|case (fp-get fp-pair fixpoints)
           (&/$Some ?)
           (if ?
@@ -870,6 +899,12 @@
         (return (&/T fixpoints nil))
         (fail (check-error expected actual)))
 
+      [(&/$NamedT ?ename ?etype) _]
+      (check* class-loader fixpoints ?etype actual)
+
+      [_ (&/$NamedT ?aname ?atype)]
+      (check* class-loader fixpoints expected ?atype)
+
       [_ _]
       (fail (check-error expected actual))
       )))
@@ -892,11 +927,15 @@
               =return (apply-lambda func* param)]
           (clean $var =return))))
 
+    (&/$NamedT ?name ?type)
+    (apply-lambda ?type param)
+
     _
     (fail (str "[Type System] Not a function type:\n" (show-type func) "\n"))
     ))
 
 (defn actual-type [type]
+  "(-> Type (Lux Type))"
   (|case type
     (&/$AppT ?all ?param)
     (|do [type* (apply-type ?all ?param)]
@@ -904,6 +943,9 @@
 
     (&/$VarT ?id)
     (deref ?id)
+
+    (&/$NamedT ?name ?type)
+    (actual-type ?type)
     
     _
     (return type)
@@ -911,6 +953,9 @@
 
 (defn variant-case [tag type]
   (|case type
+    (&/$NamedT ?name ?type)
+    (variant-case tag ?type)
+    
     (&/$VariantT ?cases)
     (|case (&/|at tag ?cases)
       (&/$Some case-type)