Made labels (tags & slots) into a form of global binding.

1 files changed, 186 insertions, 101 deletions

diff --git a/stdlib/source/library/lux.lux b/stdlib/source/library/lux.lux
index 20614dc2f..804c27ee5 100644
--- a/stdlib/source/library/lux.lux
+++ b/stdlib/source/library/lux.lux
@@ -53,7 +53,7 @@
   (9 #1 (0 #1 [[dummy_location (7 #0 ["library/lux" "type_args"])]
                [dummy_location (9 #0 (0 #1 [dummy_location (5 #0 "a")] (0 #0)))]]
            (0 #0)))]
- ["End" "Item"]
+ ("End" "Item")
  #1)
 
 ("lux def" Bit
@@ -135,7 +135,7 @@
   (9 #1 (#Item [[dummy_location (7 #0 ["library/lux" "type_args"])]
                 [dummy_location (9 #0 (#Item [dummy_location (5 #0 "a")] #End))]]
                #End))]
- ["None" "Some"]
+ ("None" "Some")
  #1)
 
 ... (type: .public Type
@@ -196,7 +196,7 @@
      ("lux type check type" (9 #0 (4 #0 1) (4 #0 0)))))
  [dummy_location
   (9 #1 #End)]
- ["Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named"]
+ ("Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named")
  #1)
 
 ... (type: .public Location
@@ -276,7 +276,7 @@
   (9 #1 (#Item [[dummy_location (7 #0 ["library/lux" "type_args"])]
                 [dummy_location (9 #0 (#Item [dummy_location (5 #0 "w")] #End))]]
                #End))]
- ["Bit" "Nat" "Int" "Rev" "Frac" "Text" "Identifier" "Tag" "Form" "Tuple" "Record"]
+ ("Bit" "Nat" "Int" "Rev" "Frac" "Text" "Identifier" "Tag" "Form" "Tuple" "Record")
  #1)
 
 ... (type: .public Code
@@ -420,15 +420,33 @@
  (record$ #End)
  .public)
 
+... (type: .public Label
+...   [Bit Type (List Text) Nat])
+("lux def" Label
+ ("lux type check type"
+  (#Named ["library/lux" "Label"]
+          (#Product Bit (#Product Type (#Product (#Apply Text List) Nat)))))
+ (record$ #End)
+ .public)
+
 ... (type: .public Global
-...   (#Alias Alias)
-...   (#Definition Definition))
+...   (Variant
+...    (#Definition Definition)
+...    (#Type [Bit Type (Either [Text (List Text)] [Text (List Text)])])
+...    (#Tag Label)
+...    (#Slot Label)
+...    (#Alias Alias)))
 ("lux def type tagged" Global
  (#Named ["library/lux" "Global"]
-         (#Sum Alias
-               Definition))
+         (#Sum Definition
+               (#Sum ({labels
+                       (#Product Bit (#Product Type (#Sum labels labels)))}
+                      (#Product Text (#Apply Text List)))
+                     (#Sum Label
+                           (#Sum Label
+                                 Alias)))))
  (record$ #End)
- ["Alias" "Definition"]
+ ("Definition" "Type" "Label" "Slot" "Alias")
  .public)
 
 ... (type: .public (Bindings k v)
@@ -460,7 +478,7 @@
           ... Captured
           Nat))
  (record$ #End)
- ["Local" "Captured"]
+ ("Local" "Captured")
  .public)
 
 ... (type: .public Scope
@@ -502,7 +520,7 @@
  (record$ (#Item [(tag$ ["library/lux" "type_args"])
                   (tuple$ (#Item (text$ "l") (#Item (text$ "r") #End)))]
                  #End))
- ["Left" "Right"]
+ ("Left" "Right")
  .public)
 
 ... (type: .public Source
@@ -529,47 +547,39 @@
            ... #Cached
            Any)))
  (record$ #End)
- ["Active" "Compiled" "Cached"]
+ ("Active" "Compiled" "Cached")
  .public)
 
 ... (type: .public Module
-...   {#module_hash        Nat
-...    #module_aliases     (List [Text Text])
-...    #definitions        (List [Text Global])
-...    #imports            (List Text)
-...    #tags               (List [Text [Nat (List Name) Bit Type]])
-...    #types              (List [Text [(List Name) Bit Type]])
-...    #module_annotations (Maybe Code)
-...    #module_state       Module_State})
+...   (Record
+...    {#module_hash        Nat
+...     #module_aliases     (List [Text Text])
+...     #definitions        (List [Text Global])
+...     #imports            (List Text)
+...     #module_annotations (Maybe Code)
+...     #module_state       Module_State}))
 ("lux def type tagged" Module
  (#Named ["library/lux" "Module"]
-         (#Product ... "lux.module_hash"
+         (#Product
+          ... "lux.module_hash"
           Nat
-          (#Product ... "lux.module_aliases"
+          (#Product
+           ... "lux.module_aliases"
            (#Apply (#Product Text Text) List)
-           (#Product ... "lux.definitions"
+           (#Product
+            ... "lux.definitions"
             (#Apply (#Product Text Global) List)
-            (#Product ... "lux.imports"
+            (#Product
+             ... "lux.imports"
              (#Apply Text List)
-             (#Product ... "lux.tags"
-              (#Apply (#Product Text
-                                (#Product Nat
-                                          (#Product (#Apply Name List)
-                                                    (#Product Bit
-                                                              Type))))
-                      List)
-              (#Product ... "lux.types"
-               (#Apply (#Product Text
-                                 (#Product (#Apply Name List)
-                                           (#Product Bit
-                                                     Type)))
-                       List)
-               (#Product ... "lux.module_annotations"
-                (#Apply Code Maybe)
-                Module_State))
-              ))))))
+             (#Product
+              ... "lux.module_annotations"
+              (#Apply Code Maybe)
+              ... module_state
+              Module_State)
+             )))))
  (record$ #End)
- ["module_hash" "module_aliases" "definitions" "imports" "tags" "types" "module_annotations" "module_state"]
+ ["module_hash" "module_aliases" "definitions" "imports" "module_annotations" "module_state"]
  .public)
 
 ... (type: .public Type_Context
@@ -602,7 +612,7 @@
            ... Interpreter
            Any)))
  (record$ #End)
- ["Build" "Eval" "Interpreter"]
+ ("Build" "Eval" "Interpreter")
  .public)
 
 ... (type: .public Info
@@ -1668,13 +1678,22 @@
                  #scopes scopes #type_context types    #host    host
                  #seed seed #expected  expected #location  location #extensions extensions
                  #scope_type_vars scope_type_vars #eval _eval} state]
-               ({(#Some {#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _})
+               ({(#Some {#module_hash _ #module_aliases _ #definitions definitions #imports _ #module_annotations _ #module_state _})
                  ({(#Some constant)
-                   ({(#Left real_name)
+                   ({(#Alias real_name)
                      (#Right [state real_name])
                      
-                     (#Right [exported? def_type def_meta def_value])
-                     (#Right [state full_name])}
+                     (#Definition [exported? def_type def_meta def_value])
+                     (#Right [state full_name])
+
+                     (#Type [exported? type labels])
+                     (#Right [state full_name])
+
+                     (#Label _)
+                     (#Left ($_ text\composite "Unknown definition: " (name\encoded full_name)))
+
+                     (#Slot _)
+                     (#Left ($_ text\composite "Unknown definition: " (name\encoded full_name)))}
                     constant)
 
                    #None
@@ -2189,26 +2208,35 @@
            #0}
           type))
 
-(def:''' .private (macro' modules current_module module name)
+(def:''' .private (macro'' modules current_module module name)
          #End
          (-> ($' List (Tuple Text Module))
              Text Text Text
              ($' Maybe Macro))
          (do maybe_monad
            [$module (plist\value module modules)
-            gdef (let' [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags #types types #module_annotations _ #module_state _} ("lux type check" Module $module)]
+            gdef (let' [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #module_annotations _ #module_state _} ("lux type check" Module $module)]
                        (plist\value name bindings))]
-           ({(#Left [r_module r_name])
-             (macro' modules current_module r_module r_name)
+           ({(#Alias [r_module r_name])
+             (macro'' modules current_module r_module r_name)
 
-             (#Right [exported? def_type def_meta def_value])
+             (#Definition [exported? def_type def_meta def_value])
              (if (macro_type? def_type)
                (if exported?
                  (#Some ("lux type as" Macro def_value))
                  (if (text\= module current_module)
                    (#Some ("lux type as" Macro def_value))
                    #None))
-               #None)}
+               #None)
+
+             (#Type [exported? type labels])
+             #None
+
+             (#Label _)
+             #None
+
+             (#Slot _)
+             #None}
             ("lux type check" Global gdef))))
 
 (def:''' .private (normal name)
@@ -2223,7 +2251,7 @@
            (in_meta name)}
           name))
 
-(def:''' .private (macro full_name)
+(def:''' .private (macro' full_name)
          #End
          (-> Name ($' Meta ($' Maybe Macro)))
          (do meta_monad
@@ -2235,7 +2263,7 @@
                                #seed   seed #expected expected
                                #location location #extensions extensions
                                #scope_type_vars scope_type_vars #eval _eval}
-                              (#Right state (macro' modules current_module module name))}
+                              (#Right state (macro'' modules current_module module name))}
                              state)))))
 
 (def:''' .private (macro? name)
@@ -2243,7 +2271,7 @@
          (-> Name ($' Meta Bit))
          (do meta_monad
            [name (normal name)
-            output (macro name)]
+            output (macro' name)]
            (in ({(#Some _) #1
                  #None     #0}
                 output))))
@@ -2268,7 +2296,7 @@
          ({[_ (#Form (#Item [_ (#Identifier name)] args))]
            (do meta_monad
              [name' (normal name)
-              ?macro (macro name')]
+              ?macro (macro' name')]
              ({(#Some macro)
                (("lux type as" Macro' macro) args)
                
@@ -2286,7 +2314,7 @@
          ({[_ (#Form (#Item [_ (#Identifier name)] args))]
            (do meta_monad
              [name' (normal name)
-              ?macro (macro name')]
+              ?macro (macro' name')]
              ({(#Some macro)
                (do meta_monad
                  [top_level_expansion (("lux type as" Macro' macro) args)
@@ -2307,7 +2335,7 @@
          ({[_ (#Form (#Item [_ (#Identifier name)] args))]
            (do meta_monad
              [name' (normal name)
-              ?macro (macro name')]
+              ?macro (macro' name')]
              ({(#Some macro)
                (do meta_monad
                  [expansion (("lux type as" Macro' macro) args)
@@ -3270,17 +3298,22 @@
         _
         (#Left ($_ text\composite "Unknown module: " name))))))
 
-(def: (type_tag [module name])
+(def: (type_slot [module name])
   (-> Name (Meta [Nat (List Name) Bit Type]))
   (do meta_monad
     [=module (..module module)
-     .let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags_table #types types #module_annotations _ #module_state _} =module]]
-    (case (plist\value name tags_table)
-      (#Some output)
-      (in_meta output)
+     .let [{#module_hash _ #module_aliases _ #definitions definitions #imports _ #module_annotations _ #module_state _} =module]]
+    (case (plist\value (text\composite "#" name) definitions)
+      (#Some (#Slot [exported type group index]))
+      (in_meta [index
+                (list\each (function (_ slot)
+                             [module slot])
+                           group)
+                exported
+                type])
 
       _
-      (failure (text\composite "Unknown tag: " (name\encoded [module name]))))))
+      (failure (text\composite "Unknown slot: " (name\encoded [module name]))))))
 
 (def: (record_slots type)
   (-> Type (Meta (Maybe [(List Name) (List Type)])))
@@ -3297,12 +3330,14 @@
     (#Named [module name] unnamed)
     (do meta_monad
       [=module (..module module)
-       .let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags #types types #module_annotations _ #module_state _} =module]]
-      (case (plist\value name types)
-        (#Some [tags exported? (#Named _ _type)])
+       .let [{#module_hash _ #module_aliases _ #definitions definitions #imports _ #module_annotations _ #module_state _} =module]]
+      (case (plist\value name definitions)
+        (#Some (#Type [exported? (#Named _ _type) (#Right slots)]))
         (case (interface_methods _type)
           (#Some members)
-          (in_meta (#Some [tags members]))
+          (in_meta (#Some [(list\each (function (_ slot) [module slot])
+                                      (#Item slots))
+                           members]))
 
           _
           (in_meta #None))
@@ -3520,9 +3555,9 @@
   (case (everyP caseP tokens)
     (#Some cases)
     (in_meta (list (` (..Union (~+ (list\each product\right cases))))
-                   (tuple$ (list\each (function (_ case)
-                                        (text$ (product\left case)))
-                                      cases))))
+                   (form$ (list\each (function (_ case)
+                                       (text$ (product\left case)))
+                                     cases))))
     
     #None
     (failure "Wrong syntax for Variant")))
@@ -3616,15 +3651,23 @@
     #None))
 
 (def: (type_declaration it)
-  (-> Code (Meta (Tuple Code (Maybe (List Text)))))
+  (-> Code (Meta (Tuple Code (Maybe (Either (List Text) (List Text))))))
   ({[_ (#Form (#Item [_ (#Identifier declarer)] parameters))]
     (do meta_monad
       [declaration (single_expansion (form$ (list& (identifier$ declarer) parameters)))]
       (case declaration
-        (^ (list type [_ (#Tuple tags)]))
+        (^ (list type [_ (#Form tags)]))
         (case (everyP textP tags)
           (#Some tags)
-          (in_meta [type (#Some tags)])
+          (in_meta [type (#Some (#Left tags))])
+          
+          #None
+          (failure "Improper type-definition syntax"))
+
+        (^ (list type [_ (#Tuple slots)]))
+        (case (everyP textP slots)
+          (#Some slots)
+          (in_meta [type (#Some (#Right slots))])
           
           #None
           (failure "Improper type-definition syntax"))
@@ -3643,10 +3686,10 @@
   (case (typeP tokens)
     (#Some [export_policy name args meta type_codes])
     (do meta_monad
-      [type+tags?? (..type_declaration type_codes)
+      [type+labels?? (..type_declaration type_codes)
        module_name current_module_name
        .let' [type_name (local_identifier$ name)
-              [type tags??] type+tags??
+              [type labels??] type+labels??
               type' (: (Maybe Code)
                        (case args
                          #End
@@ -3663,13 +3706,22 @@
         (let [typeC (` (#.Named [(~ (text$ module_name))
                                  (~ (text$ name))]
                                 (.type (~ type''))))]
-          (in_meta (list (case tags??
-                           (#Some tags)
-                           (` ("lux def type tagged" (~ type_name)
-                               (~ typeC)
-                               (~ total_meta)
-                               [(~+ (list\each text$ tags))]
-                               (~ export_policy)))
+          (in_meta (list (case labels??
+                           (#Some labels)
+                           (case labels
+                             (#Left tags)
+                             (` ("lux def type tagged" (~ type_name)
+                                 (~ typeC)
+                                 (~ total_meta)
+                                 ((~+ (list\each text$ tags)))
+                                 (~ export_policy)))
+                             
+                             (#Right slots)
+                             (` ("lux def type tagged" (~ type_name)
+                                 (~ typeC)
+                                 (~ total_meta)
+                                 [(~+ (list\each text$ slots))]
+                                 (~ export_policy))))
                            
                            _
                            (` ("lux def" (~ type_name)
@@ -3980,14 +4032,25 @@
                                        (List Text))
                                    (function (_ [name definition])
                                      (case definition
-                                       (#Left _)
+                                       (#Alias _)
                                        (list)
 
-                                       (#Right [exported? def_type def_meta def_value])
+                                       (#Definition [exported? def_type def_meta def_value])
+                                       (if exported?
+                                         (list name)
+                                         (list))
+
+                                       (#Type [exported? type labels])
                                        (if exported?
                                          (list name)
-                                         (list)))))
-                                (let [{#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _} =module]
+                                         (list))
+
+                                       (#Label _)
+                                       (list)
+
+                                       (#Slot _)
+                                       (list))))
+                                (let [{#module_hash _ #module_aliases _ #definitions definitions #imports _ #module_annotations _ #module_state _} =module]
                                   definitions))]
         (#Right state (list\conjoint to_alias)))
       
@@ -4069,18 +4132,27 @@
       #None
       #None
 
-      (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _})
+      (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #module_annotations _ #module_state _})
       (case (plist\value v_name definitions)
         #None
         #None
 
         (#Some definition)
         (case definition
-          (#Left real_name)
+          (#Alias real_name)
           (definition_type real_name state)
           
-          (#Right [exported? def_type def_meta def_value])
-          (#Some def_type))))))
+          (#Definition [exported? def_type def_meta def_value])
+          (#Some def_type)
+
+          (#Type [exported? type labels])
+          (#Some ..Type)
+
+          (#Label _)
+          #None
+
+          (#Slot _)
+          #None)))))
 
 (def: (definition_value name state)
   (-> Name (Meta [Type Any]))
@@ -4093,18 +4165,27 @@
       #None
       (#Left (text\composite "Unknown definition: " (name\encoded name)))
 
-      (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _})
+      (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #module_annotations _ #module_state _})
       (case (plist\value v_name definitions)
         #None
         (#Left (text\composite "Unknown definition: " (name\encoded name)))
 
         (#Some definition)
         (case definition
-          (#Left real_name)
+          (#Alias real_name)
           (definition_value real_name state)
           
-          (#Right [exported? def_type def_meta def_value])
-          (#Right [state [def_type def_value]]))))))
+          (#Definition [exported? def_type def_meta def_value])
+          (#Right [state [def_type def_value]])
+
+          (#Type [exported? type labels])
+          (#Right [state [..Type type]])
+
+          (#Label _)
+          (#Left (text\composite "Unknown definition: " (name\encoded name)))
+
+          (#Slot _)
+          (#Left (text\composite "Unknown definition: " (name\encoded name))))))))
 
 (def: (type_variable idx bindings)
   (-> Nat (List [Nat (Maybe Type)]) (Maybe Type))
@@ -4254,7 +4335,7 @@
     (^ (list [_ (#Tag slot')] record))
     (do meta_monad
       [slot (normal slot')
-       output (..type_tag slot)
+       output (..type_slot slot)
        .let [[idx tags exported? type] output]
        g!_ (..identifier "_")
        g!output (..identifier "")]
@@ -4366,7 +4447,7 @@
   (-> Text Text (Meta Bit))
   (do meta_monad
     [module (module module_name)
-     .let [{#module_hash _ #module_aliases _ #definitions _ #imports imports #tags _ #types _ #module_annotations _ #module_state _} module]]
+     .let [{#module_hash _ #module_aliases _ #definitions _ #imports imports #module_annotations _ #module_state _} module]]
     (in (is_member? imports import_name))))
 
 (def: (referrals module_name options)
@@ -4514,7 +4595,7 @@
     (^ (list [_ (#Tag slot')] value record))
     (do meta_monad
       [slot (normal slot')
-       output (..type_tag slot)
+       output (..type_slot slot)
        .let [[idx tags exported? type] output]]
       (case (interface_methods type)
         (#Some members)
@@ -4593,7 +4674,7 @@
     (^ (list [_ (#Tag slot')] fun record))
     (do meta_monad
       [slot (normal slot')
-       output (..type_tag slot)
+       output (..type_slot slot)
        .let [[idx tags exported? type] output]]
       (case (interface_methods type)
         (#Some members)
@@ -4798,7 +4879,7 @@
        .let [[hslot tslots] slots]
        hslot (..normal hslot)
        tslots (monad\each meta_monad ..normal tslots)
-       output (..type_tag hslot)
+       output (..type_slot hslot)
        g!_ (..identifier "_")
        .let [[idx tags exported? type] output
              slot_pairings (list\each (: (-> Name [Text Code])
@@ -5520,3 +5601,7 @@
 
     _
     (failure "Wrong syntax for Rec")))
+
+(def: .public macro
+  (-> Macro Macro')
+  (|>> (:as Macro')))