From 1680d4d8bc4046ed4728413f1e7cfd77aa7e84b7 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 29 Aug 2021 14:57:15 -0400 Subject: Made labels (tags & slots) into a form of global binding. --- stdlib/source/library/lux.lux | 287 +++++++++++++++++++++++++++--------------- 1 file changed, 186 insertions(+), 101 deletions(-) (limited to 'stdlib/source/library/lux.lux') 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'))) -- cgit v1.2.3