From 70005a6dee1eba3e3f5694aa4903e95988dcaa3d Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 13 Nov 2017 23:26:06 -0400
Subject: - Refactoring. - Now giving type checking/inference a higher
 priority. - Better error messages.

---
 new-luxc/source/luxc/module.lux | 48 +++++++++++++++++++++++++----------------
 1 file changed, 30 insertions(+), 18 deletions(-)

(limited to 'new-luxc/source/luxc/module.lux')

diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux
index 2bb7eedcd..7b60af8f2 100644
--- a/new-luxc/source/luxc/module.lux
+++ b/new-luxc/source/luxc/module.lux
@@ -1,14 +1,21 @@
 (;module:
   lux
-  (lux (control [monad #+ do])
-       (data [text "T/" Eq<Text>]
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:])
+       (data [text "text/" Eq<Text>]
              text/format
              ["e" error]
-             (coll [list "L/" Fold<List> Functor<List>]))
-       [meta #+ Monad<Meta>])
+             (coll [list "list/" Fold<List> Functor<List>]))
+       [meta]
+       (meta [code]))
   (luxc ["&" base]
         ["&;" scope]))
 
+(exception: #export Unknown-Module)
+(exception: #export Cannot-Declare-Tag-Twice)
+(exception: #export Cannot-Declare-Tags-For-Unnamed-Type)
+(exception: #export Cannot-Declare-Tags-For-Foreign-Type)
+
 (def: (new-module hash)
   (-> Nat Module)
   {#;module-hash        hash
@@ -54,7 +61,7 @@
 
 (def: #export (with-module hash name action)
   (All [a] (-> Nat Text (Meta a) (Meta [Module a])))
-  (do Monad<Meta>
+  (do meta;Monad<Meta>
     [_ (create hash name)
      output (&;with-current-module name
               (&scope;with-scope name action))
@@ -107,7 +114,7 @@
          (#e;Success [compiler (get@ <tag> module)])
 
          #;None
-         (meta;run compiler (&;fail (format "Unknown module: " module-name))))
+         (meta;run compiler (&;throw Unknown-Module module-name)))
        ))]
 
   [tags-by-module  #;tags        (List [Text [Nat (List Ident) Bool Type]])]
@@ -117,7 +124,7 @@
 
 (def: (ensure-undeclared-tags module-name tags)
   (-> Text (List Text) (Meta Unit))
-  (do Monad<Meta>
+  (do meta;Monad<Meta>
     [bindings (tags-by-module module-name)
      _ (monad;map @
                   (function [tag]
@@ -126,36 +133,41 @@
                       (wrap [])
 
                       (#;Some _)
-                      (&;fail (format "Cannot re-declare tag: " tag))))
+                      (&;throw Cannot-Declare-Tag-Twice (format "Module: " module-name "\n"
+                                                                "   Tag: " tag))))
                   tags)]
     (wrap [])))
 
 (def: #export (declare-tags tags exported? type)
   (-> (List Text) Bool Type (Meta Unit))
-  (do Monad<Meta>
+  (do meta;Monad<Meta>
     [current-module meta;current-module-name
      [type-module type-name] (case type
                                (#;Named type-ident _)
                                (wrap type-ident)
 
                                _
-                               (&;fail (format "Cannot define tags for an unnamed type: " (%type type))))
+                               (&;throw Cannot-Declare-Tags-For-Unnamed-Type
+                                        (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n"
+                                                "Type: " (%type type))))
      _ (ensure-undeclared-tags current-module tags)
-     _ (meta;assert (format "Cannot define tags for a type belonging to a foreign module: " (%type type))
-                    (T/= current-module type-module))]
+     _ (&;assert Cannot-Declare-Tags-For-Foreign-Type
+                 (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n"
+                         "Type: " (%type type))
+                 (text/= current-module type-module))]
     (function [compiler]
       (case (|> compiler (get@ #;modules) (&;pl-get current-module))
         (#;Some module)
-        (let [namespaced-tags (L/map (|>. [current-module]) tags)]
+        (let [namespaced-tags (list/map (|>. [current-module]) tags)]
           (#e;Success [(update@ #;modules
                                 (&;pl-update current-module
                                              (|>. (update@ #;tags (function [tag-bindings]
-                                                                    (L/fold (function [[idx tag] table]
-                                                                              (&;pl-put tag [idx namespaced-tags exported? type] table))
-                                                                            tag-bindings
-                                                                            (list;enumerate tags))))
+                                                                    (list/fold (function [[idx tag] table]
+                                                                                 (&;pl-put tag [idx namespaced-tags exported? type] table))
+                                                                               tag-bindings
+                                                                               (list;enumerate tags))))
                                                   (update@ #;types (&;pl-put type-name [namespaced-tags exported? type]))))
                                 compiler)
                        []]))
         #;None
-        (meta;run compiler (&;fail (format "Unknown module: " current-module)))))))
+        (meta;run compiler (&;throw Unknown-Module current-module))))))
-- 
cgit v1.2.3