diff options
Diffstat (limited to '')
25 files changed, 616 insertions, 390 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'))) diff --git a/stdlib/source/library/lux/control/function/mutual.lux b/stdlib/source/library/lux/control/function/mutual.lux index 3d26dedd1..5ef853829 100644 --- a/stdlib/source/library/lux/control/function/mutual.lux +++ b/stdlib/source/library/lux/control/function/mutual.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Definition let def:) + [lux (#- Definition let def: macro) ["." meta] [abstract ["." monad (#+ do)]] diff --git a/stdlib/source/library/lux/control/parser/binary.lux b/stdlib/source/library/lux/control/parser/binary.lux index 409d2a872..6c0f82a06 100644 --- a/stdlib/source/library/lux/control/parser/binary.lux +++ b/stdlib/source/library/lux/control/parser/binary.lux @@ -110,16 +110,28 @@ [(do {! //.monad} [flag (: (Parser Nat) ..bits/8)] - (`` (case flag - (^template [<number> <tag> <parser>] - [<number> (\ ! each (|>> <tag>) <parser>)]) - ((~~ (template.spliced <case>+))) - _ (//.lifted (exception.except ..invalid_tag [(~~ (template.amount <case>+)) flag])))))]) + (with_expansions [<case>+' (template.spliced <case>+)] + (case flag + (^template [<number> <tag> <parser>] + [<number> (`` (\ ! each (|>> ((~~ (template.spliced <tag>)))) <parser>))]) + (<case>+') + + _ (//.lifted (exception.except ..invalid_tag [(template.amount [<case>+]) flag])))))]) (def: .public (or left right) (All (_ l r) (-> (Parser l) (Parser r) (Parser (Or l r)))) - (!variant [[0 #.Left left] - [1 #.Right right]])) + (!variant [[0 [#.Left] left] + [1 [#.Right] right]])) + +(def: .public (or/5 p/0 p/1 p/2 p/3 p/4) + (All (_ p/0 p/1 p/2 p/3 p/4) + (-> (Parser p/0) (Parser p/1) (Parser p/2) (Parser p/3) (Parser p/4) + (Parser (Or p/0 p/1 p/2 p/3 p/4)))) + (!variant [[0 [0 #0] p/0] + [1 [1 #0] p/1] + [2 [2 #0] p/2] + [3 [3 #0] p/3] + [4 [3 #1] p/4]])) (def: .public (rec body) (All (_ a) (-> (-> (Parser a) (Parser a)) (Parser a))) @@ -242,17 +254,17 @@ (let [pair (//.and type type) indexed ..nat quantified (//.and (..list type) type)] - (!variant [[0 #.Primitive (//.and ..text (..list type))] - [1 #.Sum pair] - [2 #.Product pair] - [3 #.Function pair] - [4 #.Parameter indexed] - [5 #.Var indexed] - [6 #.Ex indexed] - [7 #.UnivQ quantified] - [8 #.ExQ quantified] - [9 #.Apply pair] - [10 #.Named (//.and ..name type)]]))))) + (!variant [[0 [#.Primitive] (//.and ..text (..list type))] + [1 [#.Sum] pair] + [2 [#.Product] pair] + [3 [#.Function] pair] + [4 [#.Parameter] indexed] + [5 [#.Var] indexed] + [6 [#.Ex] indexed] + [7 [#.UnivQ] quantified] + [8 [#.ExQ] quantified] + [9 [#.Apply] pair] + [10 [#.Named] (//.and ..name type)]]))))) (def: .public location (Parser Location) @@ -264,14 +276,14 @@ (function (_ recur) (let [sequence (..list recur)] (//.and ..location - (!variant [[0 #.Bit ..bit] - [1 #.Nat ..nat] - [2 #.Int ..int] - [3 #.Rev ..rev] - [4 #.Frac ..frac] - [5 #.Text ..text] - [6 #.Identifier ..name] - [7 #.Tag ..name] - [8 #.Form sequence] - [9 #.Tuple sequence] - [10 #.Record (..list (//.and recur recur))]])))))) + (!variant [[0 [#.Bit] ..bit] + [1 [#.Nat] ..nat] + [2 [#.Int] ..int] + [3 [#.Rev] ..rev] + [4 [#.Frac] ..frac] + [5 [#.Text] ..text] + [6 [#.Identifier] ..name] + [7 [#.Tag] ..name] + [8 [#.Form] sequence] + [9 [#.Tuple] sequence] + [10 [#.Record] (..list (//.and recur recur))]])))))) diff --git a/stdlib/source/library/lux/data/format/binary.lux b/stdlib/source/library/lux/data/format/binary.lux index 109b1c19d..8ffed2724 100644 --- a/stdlib/source/library/lux/data/format/binary.lux +++ b/stdlib/source/library/lux/data/format/binary.lux @@ -98,6 +98,29 @@ [1 #.Right right]) ))) +(def: .public (or/5 w/0 w/1 w/2 w/3 w/4) + (All (_ w/0 w/1 w/2 w/3 w/4) + (-> (Writer w/0) (Writer w/1) (Writer w/2) (Writer w/3) (Writer w/4) + (Writer (Or w/0 w/1 w/2 w/3 w/4)))) + (function (_ altV) + (case altV + (^template [<number> <tag> <right?> <writer>] + [(<tag> <right?> caseV) + (let [[caseS caseT] (<writer> caseV)] + [(.++ caseS) + (function (_ [offset binary]) + (|> binary + (binary.write/8! offset <number>) + try.trusted + [(.++ offset)] + caseT))])]) + ([0 0 #0 w/0] + [1 1 #0 w/1] + [2 2 #0 w/2] + [3 3 #0 w/3] + [4 3 #1 w/4]) + ))) + (def: .public (and pre post) (All (_ a b) (-> (Writer a) (Writer b) (Writer [a b]))) (function (_ [preV postV]) diff --git a/stdlib/source/library/lux/macro/template.lux b/stdlib/source/library/lux/macro/template.lux index 65b4f96ba..3c18f9f9e 100644 --- a/stdlib/source/library/lux/macro/template.lux +++ b/stdlib/source/library/lux/macro/template.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- let local) + [lux (#- let local macro) ["." meta] [abstract ["." monad (#+ do)]] diff --git a/stdlib/source/library/lux/meta.lux b/stdlib/source/library/lux/meta.lux index 208663367..f19bc2964 100644 --- a/stdlib/source/library/lux/meta.lux +++ b/stdlib/source/library/lux/meta.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- type) + [lux (#- type macro) [abstract [functor (#+ Functor)] [apply (#+ Apply)] @@ -189,7 +189,16 @@ (#.Definition [exported? def_type def_anns def_value]) (if (macro_type? def_type) (#.Some (:as Macro def_value)) - #.None))))))]))))) + #.None) + + (#.Type [exported? type labels]) + #.None + + (#.Label _) + #.None + + (#.Slot _) + #.None)))))]))))) (def: .public seed (Meta Nat) @@ -315,13 +324,20 @@ (value@ #.definitions) (list.all (function (_ [def_name global]) (case global - (#.Definition [exported? _ _ _]) + (^or (#.Definition [exported? _]) + (#.Type [exported? _])) (if (and exported? (text\= normal_short def_name)) (#.Some (name\encoded [module_name def_name])) #.None) (#.Alias _) + #.None + + (#.Label _) + #.None + + (#.Slot _) #.None)))))) list.together (list.sorted text\<) @@ -348,27 +364,55 @@ (do ..monad [definition (..definition name)] (case definition - (#.Left de_aliased) - (failure ($_ text\composite - "Aliases are not considered exports: " - (name\encoded name))) - - (#.Right definition) + (#.Definition definition) (let [[exported? def_type def_data def_value] definition] (if exported? (in definition) - (failure ($_ text\composite "Definition is not an export: " (name\encoded name)))))))) + (failure ($_ text\composite "Definition is not an export: " (name\encoded name))))) + + (#.Type [exported? type labels]) + (if exported? + (in [exported? .Type (' {}) type]) + (failure ($_ text\composite "Type is not an export: " (name\encoded name)))) + + (#.Alias de_aliased) + (failure ($_ text\composite + "Aliases are not considered exports: " + (name\encoded name))) + + (#.Label _) + (failure ($_ text\composite + "Tags are not considered exports: " + (name\encoded name))) + + (#.Slot _) + (failure ($_ text\composite + "Slots are not considered exports: " + (name\encoded name)))))) (def: .public (definition_type name) (-> Name (Meta Type)) (do ..monad [definition (definition name)] (case definition - (#.Left de_aliased) + (#.Alias de_aliased) (definition_type de_aliased) - (#.Right [exported? def_type def_data def_value]) - (clean_type def_type)))) + (#.Definition [exported? def_type def_data def_value]) + (clean_type def_type) + + (#.Type [exported? type labels]) + (in .Type) + + (#.Label _) + (failure ($_ text\composite + "Tags have no type: " + (name\encoded name))) + + (#.Slot _) + (failure ($_ text\composite + "Slots have no type: " + (name\encoded name)))))) (def: .public (type name) (-> Name (Meta Type)) @@ -385,17 +429,26 @@ (do ..monad [definition (definition name)] (case definition - (#.Left de_aliased) + (#.Alias de_aliased) (type_definition de_aliased) - (#.Right [exported? def_type def_data def_value]) + (#.Definition [exported? def_type def_data def_value]) (let [type_code (`` ("lux in-module" (~~ (static .prelude_module)) .type_code))] (if (or (same? .Type def_type) (\ code.equivalence = (type_code .Type) (type_code def_type))) (in (:as Type def_value)) - (..failure ($_ text\composite "Definition is not a type: " (name\encoded name)))))))) + (..failure ($_ text\composite "Definition is not a type: " (name\encoded name))))) + + (#.Type [exported? type labels]) + (in type) + + (#.Label _) + (..failure ($_ text\composite "Tag is not a type: " (name\encoded name))) + + (#.Slot _) + (..failure ($_ text\composite "Slot is not a type: " (name\encoded name)))))) (def: .public (globals module) (-> Text (Meta (List [Text Global]))) @@ -412,11 +465,20 @@ (\ ..monad each (list.all (function (_ [name global]) (case global - (#.Left de_aliased) + (#.Alias de_aliased) #.None - (#.Right definition) - (#.Some [name definition])))) + (#.Definition definition) + (#.Some [name definition]) + + (#.Type [exported? type labels]) + (#.Some [name [exported? .Type (' {}) type]]) + + (#.Label _) + #.None + + (#.Slot _) + #.None))) (..globals module))) (def: .public (exports module_name) @@ -440,11 +502,12 @@ (def: .public (tags_of type_name) (-> Name (Meta (Maybe (List Name)))) (do ..monad - [.let [[module name] type_name] - module (..module module)] - (case (plist.value name (value@ #.types module)) - (#.Some [tags _]) - (in (#.Some tags)) + [.let [[module_name name] type_name] + module (..module module_name)] + (case (plist.value name (value@ #.definitions module)) + (#.Some (#.Type [exported? type (#.Right slots)])) + (in (#.Some (list\each (|>> [module_name]) + (#.Item slots)))) _ (in #.None)))) @@ -489,33 +552,41 @@ =module (..module module) this_module_name ..current_module_name imported! (..imported? module)] - (case (plist.value name (value@ #.tags =module)) - (#.Some [idx tag_list exported? type]) + (case (plist.value (text\composite "#" name) (value@ #.definitions =module)) + (^or (#.Some (#.Label [exported? type group idx])) + (#.Some (#.Slot [exported? type group idx]))) (if (or (text\= this_module_name module) (and imported! exported?)) - (in [idx tag_list type]) + (in [idx (list\each (|>> [module]) group) type]) (..failure ($_ text\composite "Cannot access tag: " (name\encoded tag_name) " from module " this_module_name))) _ (..failure ($_ text\composite - "Unknown tag: " (name\encoded tag_name) text.new_line - " Known tags: " (|> =module - (value@ #.tags) - (list\each (|>> product.left [module] name\encoded (text.prefix text.new_line))) - text.together) - ))))) + "Unknown tag: " (name\encoded tag_name)))))) (def: .public (tag_lists module) (-> Text (Meta (List [(List Name) Type]))) (do ..monad [=module (..module module) this_module_name ..current_module_name] - (in (|> (value@ #.types =module) - (list.only (function (_ [type_name [tag_list exported? type]]) - (or exported? - (text\= this_module_name module)))) - (list\each (function (_ [type_name [tag_list exported? type]]) - [tag_list type])))))) + (in (list.all (function (_ [short global]) + (case global + (#.Type [exported? type labels]) + (if (or exported? + (text\= this_module_name module)) + (#.Some [(list\each (|>> [module]) + (case labels + (#.Left tags) + (#.Item tags) + + (#.Right slots) + (#.Item slots))) + type]) + #.None) + + _ + #.None)) + (value@ #.definitions =module))))) (def: .public locals (Meta (List (List [Text Type]))) @@ -536,10 +607,19 @@ (do ..monad [constant (..definition def_name)] (in (case constant - (#.Left real_def_name) + (#.Alias real_def_name) real_def_name - (#.Right _) + (#.Definition _) + def_name + + (#.Type _) + def_name + + (#.Label _) + def_name + + (#.Slot _) def_name)))) (def: .public compiler_state diff --git a/stdlib/source/library/lux/target/js.lux b/stdlib/source/library/lux/target/js.lux index 07318b451..62ce204c5 100644 --- a/stdlib/source/library/lux/target/js.lux +++ b/stdlib/source/library/lux/target/js.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Location Code or and function if cond undefined for comment not int try ++ --) + [lux (#- Location Code Label or and function if cond undefined for comment not int try ++ --) [control [pipe (#+ case>)]] [data diff --git a/stdlib/source/library/lux/target/jvm.lux b/stdlib/source/library/lux/target/jvm.lux index ce273f401..50543961c 100644 --- a/stdlib/source/library/lux/target/jvm.lux +++ b/stdlib/source/library/lux/target/jvm.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Type) + [lux (#- Type Label) [data [collection [row (#+ Row)]]] diff --git a/stdlib/source/library/lux/target/jvm/bytecode.lux b/stdlib/source/library/lux/target/jvm/bytecode.lux index 9c106e442..53886c7b5 100644 --- a/stdlib/source/library/lux/target/jvm/bytecode.lux +++ b/stdlib/source/library/lux/target/jvm/bytecode.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Type int try) + [lux (#- Type Label int try) ["." ffi (#+ import:)] [abstract [monoid (#+ Monoid)] diff --git a/stdlib/source/library/lux/target/jvm/reflection.lux b/stdlib/source/library/lux/target/jvm/reflection.lux index 3fdf491bc..55316e26f 100644 --- a/stdlib/source/library/lux/target/jvm/reflection.lux +++ b/stdlib/source/library/lux/target/jvm/reflection.lux @@ -174,7 +174,7 @@ (do {! try.monad} [paramsT (|> reflection java/lang/reflect/ParameterizedType::getActualTypeArguments - array.list + (array.list #.None) (monad.each ! parameter))] (in (/.class (|> raw (:as (java/lang/Class java/lang/Object)) @@ -297,7 +297,7 @@ (case type (#.Primitive name params) (let [class_name (java/lang/Class::getName class) - class_params (array.list (java/lang/Class::getTypeParameters class)) + class_params (array.list #.None (java/lang/Class::getTypeParameters class)) num_class_params (list.size class_params) num_type_params (list.size params)] (if (text\= class_name name) @@ -360,7 +360,7 @@ (def: .public deprecated? (-> (array.Array java/lang/annotation/Annotation) Bit) - (|>> array.list + (|>> (array.list #.None) (list.all (|>> (ffi.check java/lang/Deprecated))) list.empty? not)) diff --git a/stdlib/source/library/lux/target/lua.lux b/stdlib/source/library/lux/target/lua.lux index 42d8d60e5..faac1b184 100644 --- a/stdlib/source/library/lux/target/lua.lux +++ b/stdlib/source/library/lux/target/lua.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Location Code int if cond function or and not let ^ local) + [lux (#- Location Code Label int if cond function or and not let ^ local) ["@" target] [abstract [equivalence (#+ Equivalence)] diff --git a/stdlib/source/library/lux/target/php.lux b/stdlib/source/library/lux/target/php.lux index 0e228dc57..a14b3e0ce 100644 --- a/stdlib/source/library/lux/target/php.lux +++ b/stdlib/source/library/lux/target/php.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Location Code Global static int if cond or and not comment for try global) + [lux (#- Location Code Global Label static int if cond or and not comment for try global) ["@" target] [abstract [equivalence (#+ Equivalence)] diff --git a/stdlib/source/library/lux/target/python.lux b/stdlib/source/library/lux/target/python.lux index 8a41d3ae8..6b24b6ae2 100644 --- a/stdlib/source/library/lux/target/python.lux +++ b/stdlib/source/library/lux/target/python.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Location Code not or and list if cond int comment exec try) + [lux (#- Location Code Label not or and list if cond int comment exec try) ["@" target] ["." ffi] [abstract diff --git a/stdlib/source/library/lux/tool/compiler/language/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux.lux index e86bd51aa..5bb42e533 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux.lux @@ -24,24 +24,23 @@ (Writer .Module) (let [definition (: (Writer Definition) ($_ _.and _.bit _.type _.code _.any)) + labels (: (Writer [Text (List Text)]) + (_.and _.text (_.list _.text))) + global_type (: (Writer [Bit Type (Either [Text (List Text)] + [Text (List Text)])]) + ($_ _.and _.bit _.type (_.or labels labels))) + global_label (: (Writer .Label) + ($_ _.and _.bit _.type (_.list _.text) _.nat)) name (: (Writer Name) (_.and _.text _.text)) alias (: (Writer Alias) (_.and _.text _.text)) global (: (Writer Global) - (_.or alias - definition)) - tag (: (Writer [Nat (List Name) Bit Type]) - ($_ _.and - _.nat - (_.list name) - _.bit - _.type)) - type (: (Writer [(List Name) Bit Type]) - ($_ _.and - (_.list name) - _.bit - _.type))] + (_.or/5 definition + global_type + global_label + global_label + alias))] ($_ _.and ... #module_hash _.nat @@ -51,10 +50,6 @@ (_.list (_.and _.text global)) ... #imports (_.list _.text) - ... #tags - (_.list (_.and _.text tag)) - ... #types - (_.list (_.and _.text type)) ... #module_annotations (_.maybe _.code) ... #module_state @@ -64,24 +59,23 @@ (Parser .Module) (let [definition (: (Parser Definition) ($_ <>.and <b>.bit <b>.type <b>.code <b>.any)) + labels (: (Parser [Text (List Text)]) + (<>.and <b>.text (<b>.list <b>.text))) + global_type (: (Parser [Bit Type (Either [Text (List Text)] + [Text (List Text)])]) + ($_ <>.and <b>.bit <b>.type (<b>.or labels labels))) + global_label (: (Parser .Label) + ($_ <>.and <b>.bit <b>.type (<b>.list <b>.text) <b>.nat)) name (: (Parser Name) (<>.and <b>.text <b>.text)) alias (: (Parser Alias) (<>.and <b>.text <b>.text)) global (: (Parser Global) - (<b>.or alias - definition)) - tag (: (Parser [Nat (List Name) Bit Type]) - ($_ <>.and - <b>.nat - (<b>.list name) - <b>.bit - <b>.type)) - type (: (Parser [(List Name) Bit Type]) - ($_ <>.and - (<b>.list name) - <b>.bit - <b>.type))] + (<b>.or/5 definition + global_type + global_label + global_label + alias))] ($_ <>.and ... #module_hash <b>.nat @@ -91,10 +85,6 @@ (<b>.list (<>.and <b>.text global)) ... #imports (<b>.list <b>.text) - ... #tags - (<b>.list (<>.and <b>.text tag)) - ... #types - (<b>.list (<>.and <b>.text type)) ... #module_annotations (<b>.maybe <b>.code) ... #module_state diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux index 42dc67db6..b6817b6c8 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux @@ -28,11 +28,6 @@ (exception.report ["Module" module])) -(exception: .public (cannot_declare_tag_twice {module Text} {tag Text}) - (exception.report - ["Module" module] - ["Tag" tag])) - (template [<name>] [(exception: .public (<name> {tags (List Text)} {owner Type}) (exception.report @@ -51,7 +46,16 @@ (format "alias " (%.name alias)) (#.Definition definition) - (format "definition " (%.name name)))])) + (format "definition " (%.name name)) + + (#.Type _) + (format "type " (%.name name)) + + (#.Label _) + (format "tag " (%.name name)) + + (#.Slot _) + (format "slot " (%.name name)))])) (exception: .public (can_only_change_state_of_active_module {module Text} {state Module_State}) (exception.report @@ -73,8 +77,6 @@ #.module_aliases (list) #.definitions (list) #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}) @@ -211,41 +213,20 @@ [set_cached cached? #.Cached] ) -(template [<name> <tag> <type>] - [(def: (<name> module_name) - (-> Text (Operation <type>)) - (///extension.lifted - (function (_ state) - (case (|> state (value@ #.modules) (plist.value module_name)) - (#.Some module) - (#try.Success [state (value@ <tag> module)]) - - #.None - ((/.except' unknown_module module_name) state)))))] +(def: (hash module_name) + (-> Text (Operation Nat)) + (///extension.lifted + (function (_ state) + (case (|> state (value@ #.modules) (plist.value module_name)) + (#.Some module) + (#try.Success [state (value@ #.module_hash module)]) - [tags #.tags (List [Text [Nat (List Name) Bit Type]])] - [types #.types (List [Text [(List Name) Bit Type]])] - [hash #.module_hash Nat] - ) + #.None + ((/.except' unknown_module module_name) state))))) -(def: (ensure_undeclared_tags module_name tags) - (-> Text (List Tag) (Operation Any)) +(def: .public (declare_tags record? tags exported? type) + (-> Bit (List Tag) Bit Type (Operation Any)) (do {! ///.monad} - [bindings (..tags module_name) - _ (monad.each ! - (function (_ tag) - (case (plist.value tag bindings) - #.None - (in []) - - (#.Some _) - (/.except ..cannot_declare_tag_twice [module_name tag]))) - tags)] - (in []))) - -(def: .public (declare_tags tags exported? type) - (-> (List Tag) Bit Type (Operation Any)) - (do ///.monad [self_name (///extension.lifted meta.current_module_name) [type_module type_name] (case type (#.Named type_name _) @@ -253,23 +234,11 @@ _ (/.except ..cannot_declare_tags_for_unnamed_type [tags type])) - _ (ensure_undeclared_tags self_name tags) _ (///.assertion cannot_declare_tags_for_foreign_type [tags type] (text\= self_name type_module))] - (///extension.lifted - (function (_ state) - (case (|> state (value@ #.modules) (plist.value self_name)) - (#.Some module) - (let [namespaced_tags (list\each (|>> [self_name]) tags)] - (#try.Success [(revised@ #.modules - (plist.revised self_name - (|>> (revised@ #.tags (function (_ tag_bindings) - (list\mix (function (_ [idx tag] table) - (plist.has tag [idx namespaced_tags exported? type] table)) - tag_bindings - (list.enumeration tags)))) - (revised@ #.types (plist.has type_name [namespaced_tags exported? type])))) - state) - []])) - #.None - ((/.except' unknown_module self_name) state)))))) + (monad.each ! (function (_ [index short]) + (..define (format "#" short) + (if record? + (#.Slot [exported? type tags index]) + (#.Label [exported? type tags index])))) + (list.enumeration tags)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux index 92a7a8f9c..d7d19e802 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux @@ -29,16 +29,20 @@ (exception.report ["Definition" (%.name definition)])) +(exception: .public (labels_are_not_definitions {definition Name}) + (exception.report + ["Label" (%.name definition)])) + (def: (definition def_name) (-> Name (Operation Analysis)) (with_expansions [<return> (in (|> def_name ///reference.constant #/.Reference))] (do {! ///.monad} [constant (///extension.lifted (meta.definition def_name))] (case constant - (#.Left real_def_name) + (#.Alias real_def_name) (definition real_def_name) - (#.Right [exported? actualT def_anns _]) + (#.Definition [exported? actualT def_anns _]) (do ! [_ (//type.infer actualT) (^@ def_name [::module ::name]) (///extension.lifted (meta.normal def_name)) @@ -51,7 +55,28 @@ (if imported! <return> (/.except foreign_module_has_not_been_imported [current ::module]))) - (/.except definition_has_not_been_exported def_name)))))))) + (/.except definition_has_not_been_exported def_name)))) + + (#.Type [exported? value labels]) + (do ! + [_ (//type.infer .Type) + (^@ def_name [::module ::name]) (///extension.lifted (meta.normal def_name)) + current (///extension.lifted meta.current_module_name)] + (if (text\= current ::module) + <return> + (if exported? + (do ! + [imported! (///extension.lifted (meta.imported_by? ::module current))] + (if imported! + <return> + (/.except foreign_module_has_not_been_imported [current ::module]))) + (/.except definition_has_not_been_exported def_name)))) + + (#.Label _) + (/.except labels_are_not_definitions [def_name]) + + (#.Slot _) + (/.except labels_are_not_definitions [def_name]))))) (def: (variable var_name) (-> Text (Operation (Maybe Analysis))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux index d3384588e..30da17c13 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -876,13 +876,13 @@ (in [[super_name superT] (java/lang/Class::isAssignableFrom super_class target_class)]))) (case (java/lang/Class::getGenericSuperclass source_class) (#.Some super) - (list& super (array.list (java/lang/Class::getGenericInterfaces source_class))) + (list& super (array.list #.None (java/lang/Class::getGenericInterfaces source_class))) #.None (if (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers source_class)) (#.Item (:as java/lang/reflect/Type (ffi.class_for java/lang/Object)) - (array.list (java/lang/Class::getGenericInterfaces source_class))) - (array.list (java/lang/Class::getGenericInterfaces source_class))))))) + (array.list #.None (java/lang/Class::getGenericInterfaces source_class))) + (array.list #.None (java/lang/Class::getGenericInterfaces source_class))))))) (def: (inheritance_candidate_parents class_loader fromT target_class toT fromC) (-> java/lang/ClassLoader .Type (java/lang/Class java/lang/Object) .Type Code (Operation (List [[Text .Type] Bit]))) @@ -1092,7 +1092,7 @@ (-> Aliasing (java/lang/Class java/lang/Object) Text Method_Style (List (Type Value)) java/lang/reflect/Method (Operation Bit)) (do phase.monad [parameters (|> (java/lang/reflect/Method::getGenericParameterTypes method) - array.list + (array.list #.None) (monad.each try.monad reflection!.type) phase.lifted) .let [modifiers (java/lang/reflect/Method::getModifiers method) @@ -1138,7 +1138,7 @@ (-> Aliasing (java/lang/Class java/lang/Object) (List (Type Value)) (java/lang/reflect/Constructor java/lang/Object) (Operation Bit)) (do phase.monad [parameters (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor) - array.list + (array.list #.None) (monad.each try.monad reflection!.type) phase.lifted)] (in (and (java/lang/Object::equals class (java/lang/reflect/Constructor::getDeclaringClass constructor)) @@ -1183,15 +1183,15 @@ _ (|> (java/lang/Class::getTypeParameters owner) - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName)))) method_tvars (|> (java/lang/reflect/Method::getTypeParameters method) - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName))) [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)] (do {! phase.monad} [inputsT (|> (java/lang/reflect/Method::getGenericParameterTypes method) - array.list + (array.list #.None) (monad.each ! (|>> reflection!.type phase.lifted)) (phase\each (monad.each ! (..reflection_type mapping))) phase\conjoint) @@ -1202,7 +1202,7 @@ (phase\each (..reflection_return mapping)) phase\conjoint) exceptionsT (|> (java/lang/reflect/Method::getGenericExceptionTypes method) - array.list + (array.list #.None) (monad.each ! (|>> reflection!.type phase.lifted)) (phase\each (monad.each ! (..reflection_type mapping))) phase\conjoint) @@ -1223,20 +1223,20 @@ (-> (java/lang/reflect/Constructor java/lang/Object) (Operation Method_Signature)) (let [owner (java/lang/reflect/Constructor::getDeclaringClass constructor) owner_tvars (|> (java/lang/Class::getTypeParameters owner) - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName))) method_tvars (|> (java/lang/reflect/Constructor::getTypeParameters constructor) - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName))) [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)] (do {! phase.monad} [inputsT (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor) - array.list + (array.list #.None) (monad.each ! (|>> reflection!.type phase.lifted)) (phase\each (monad.each ! (reflection_type mapping))) phase\conjoint) exceptionsT (|> (java/lang/reflect/Constructor::getGenericExceptionTypes constructor) - array.list + (array.list #.None) (monad.each ! (|>> reflection!.type phase.lifted)) (phase\each (monad.each ! (reflection_type mapping))) phase\conjoint) @@ -1270,7 +1270,7 @@ [(def: <name> (-> <type> (List (Type Var))) (|>> <method> - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName jvm.var))))] [class_type_variables (java/lang/Class java/lang/Object) java/lang/Class::getTypeParameters] @@ -1291,7 +1291,7 @@ .let [expected_class_tvars (class_type_variables class)] candidates (|> class java/lang/Class::getDeclaredMethods - array.list + (array.list #.None) (list.only (|>> java/lang/reflect/Method::getName (text\= method_name))) (monad.each ! (: (-> java/lang/reflect/Method (Operation Evaluation)) (function (_ method) @@ -1324,7 +1324,7 @@ .let [expected_class_tvars (class_type_variables class)] candidates (|> class java/lang/Class::getConstructors - array.list + (array.list #.None) (monad.each ! (function (_ constructor) (do ! [.let [expected_method_tvars (constructor_type_variables constructor) @@ -1549,23 +1549,23 @@ (-> (java/lang/Class java/lang/Object) (Try (List [Text (Type Method)]))) (|>> java/lang/Class::getDeclaredMethods - array.list + (array.list #.None) <only> (monad.each try.monad (function (_ method) (do {! try.monad} [.let [type_variables (|> (java/lang/reflect/Method::getTypeParameters method) - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName jvm.var)))] inputs (|> (java/lang/reflect/Method::getGenericParameterTypes method) - array.list + (array.list #.None) (monad.each ! reflection!.type)) return (|> method java/lang/reflect/Method::getGenericReturnType reflection!.return) exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method) - array.list + (array.list #.None) (monad.each ! reflection!.class))] (in [(java/lang/reflect/Method::getName method) (jvm.method [type_variables inputs return exceptions])]))))))] @@ -2066,7 +2066,7 @@ [.let [[name actual_parameters] (jvm_parser.read_class class)] class (phase.lifted (reflection!.load class_loader name)) .let [expected_parameters (|> (java/lang/Class::getTypeParameters class) - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName)))] _ (phase.assertion ..class_parameter_mismatch [expected_parameters actual_parameters] (n.= (list.size expected_parameters) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux index 7952434ee..278447d11 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux @@ -199,6 +199,10 @@ (typeA.with_type input (phase archive valueC))))])) +(exception: .public (not_a_type {symbol Name}) + (exception.report + ["Symbol" (%.name symbol)])) + (def: lux::macro Handler (..custom @@ -210,9 +214,14 @@ (do ! [input_type (///.lifted (meta.definition (name_of .Macro')))] (case input_type - (#.Definition [exported? def_type def_data def_value]) + (^or (#.Definition [exported? def_type def_data def_value]) + (#.Type [exported? def_value labels])) (in (:as Type def_value)) + (^or (#.Label _) + (#.Slot _)) + (////.failure (exception.error ..not_a_type [(name_of .Macro')])) + (#.Alias real_name) (recur real_name))))] (typeA.with_type input_type diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux index c805124dd..f2ffaccae 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux @@ -228,7 +228,7 @@ [_ _ exported?] (evaluate! archive Bit exported?C) [_ _ annotations] (evaluate! archive Code annotationsC) _ (/////directive.lifted_analysis - (module.define short_name (#.Right [(:as Bit exported?) type (:as Code annotations) value]))) + (module.define short_name (#.Definition [(:as Bit exported?) type (:as Code annotations) value]))) _ (..refresh expander host_analysis) _ (..announce_definition! short_name type)] (in /////directive.no_requirements)) @@ -236,7 +236,7 @@ _ (phase.except ///.invalid_syntax [extension_name %.code inputsC+])))) -(def: (announce_tags! tags owner) +(def: (announce_labels! tags owner) (All (_ anchor expression directive) (-> (List Text) Type (Operation anchor expression directive (List Any)))) (/////directive.lifted_generation @@ -247,8 +247,11 @@ (def: (def::type_tagged expander host_analysis) (-> Expander /////analysis.Bundle Handler) (..custom - [($_ <>.and <code>.local_identifier <code>.any <code>.any (<code>.tuple (<>.some <code>.text)) <code>.any) - (function (_ extension_name phase archive [short_name valueC annotationsC tags exported?C]) + [($_ <>.and <code>.local_identifier <code>.any <code>.any + (<>.or (<code>.form (<>.some <code>.text)) + (<code>.tuple (<>.some <code>.text))) + <code>.any) + (function (_ extension_name phase archive [short_name valueC annotationsC labels exported?C]) (do phase.monad [current_module (/////directive.lifted_analysis (///.lifted meta.current_module_name)) @@ -258,13 +261,27 @@ .let [exported? (:as Bit exported?) annotations (:as Code annotations)] [type valueT value] (..definition archive full_name (#.Some .Type) valueC) - _ (/////directive.lifted_analysis - (do phase.monad - [_ (module.define short_name (#.Right [exported? type annotations value]))] - (module.declare_tags tags exported? (:as Type value)))) + labels (/////directive.lifted_analysis + (do phase.monad + [.let [[record? labels] (case labels + (#.Left tags) + [false tags] + + (#.Right slots) + [true slots])] + _ (case labels + #.End + (module.define short_name (#.Definition [exported? type annotations value])) + + (#.Item labels) + (module.define short_name (#.Type [exported? (:as .Type value) (if record? + (#.Right labels) + (#.Left labels))]))) + _ (module.declare_tags record? labels exported? (:as .Type value))] + (in labels))) _ (..refresh expander host_analysis) _ (..announce_definition! short_name type) - _ (..announce_tags! tags (:as Type value))] + _ (..announce_labels! labels (:as Type value))] (in /////directive.no_requirements)))])) (def: imports @@ -300,17 +317,27 @@ ["Foreign alias" (%.name foreign)] ["Target definition" (%.name target)])) +(exception: .public (cannot_alias_a_label {local Alias} {foreign Alias}) + (exception.report + ["Alias" (%.name local)] + ["Label" (%.name foreign)])) + (def: (define_alias alias original) (-> Text Name (/////analysis.Operation Any)) (do phase.monad [current_module (///.lifted meta.current_module_name) constant (///.lifted (meta.definition original))] (case constant - (#.Left de_aliased) + (#.Alias de_aliased) (phase.except ..cannot_alias_an_alias [[current_module alias] original de_aliased]) - (#.Right [exported? original_type original_annotations original_value]) - (module.define alias (#.Left original))))) + (^or (#.Definition _) + (#.Type _)) + (module.define alias (#.Alias original)) + + (^or (#.Label _) + (#.Slot _)) + (phase.except ..cannot_alias_a_label [[current_module alias] original])))) (def: def::alias Handler diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux index d99cfca3d..54c3ac8ba 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Type Definition case false true try) + [lux (#- Type Definition Label case false true try) [abstract ["." monad (#+ do)] ["." enum]] diff --git a/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux index 25b9ec0b4..a2b2908b3 100644 --- a/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux +++ b/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux @@ -323,8 +323,12 @@ content (document.read $.key document) definitions (monad.each ! (function (_ [def_name def_global]) (case def_global - (#.Alias alias) - (in [def_name (#.Alias alias)]) + (^template [<tag>] + [(<tag> payload) + (in [def_name (<tag> payload)])]) + ([#.Alias] + [#.Label] + [#.Slot]) (#.Definition [exported? type annotations _]) (|> definitions @@ -332,7 +336,14 @@ try.of_maybe (\ ! each (|>> [exported? type annotations] #.Definition - [def_name]))))) + [def_name]))) + + (#.Type [exported? _ labels]) + (|> definitions + (dictionary.value def_name) + try.of_maybe + (\ ! each (function (_ def_value) + [def_name (#.Type [exported? (:as .Type def_value) labels])]))))) (value@ #.definitions content))] (in [(document.write $.key (with@ #.definitions definitions content)) bundles]))) diff --git a/stdlib/source/library/lux/type/abstract.lux b/stdlib/source/library/lux/type/abstract.lux index 837f6ba11..9a0edab98 100644 --- a/stdlib/source/library/lux/type/abstract.lux +++ b/stdlib/source/library/lux/type/abstract.lux @@ -60,11 +60,14 @@ (-> Text (List [Text Global]) (Stack Frame)) (!peek source reference (case head - (#.Left _) - (undefined) + (#.Definition [exported? frame_type frame_anns frame_value]) + (:as (Stack Frame) frame_value) - (#.Right [exported? frame_type frame_anns frame_value]) - (:as (Stack Frame) frame_value)))) + (^or (#.Type _) + (#.Alias _) + (#.Label _) + (#.Slot _)) + (undefined)))) (def: (peek_frames reference definition_reference source) (-> Text Text (List [Text Module]) (Stack Frame)) @@ -117,14 +120,17 @@ (-> Text Frame (List [Text Global]) (List [Text Global])) (!push source reference (case head - (#.Left _) - (undefined) - - (#.Right [exported? frames_type frames_anns frames_value]) - (#.Right [exported? - frames_type - frames_anns - (..push frame (:as (Stack Frame) frames_value))])))) + (#.Definition [exported? frames_type frames_anns frames_value]) + (#.Definition [exported? + frames_type + frames_anns + (..push frame (:as (Stack Frame) frames_value))]) + + (^or (#.Type _) + (#.Alias _) + (#.Label _) + (#.Slot _)) + (undefined)))) (def: (push_frame [module_reference definition_reference] frame source) (-> Name Frame (List [Text Module]) (List [Text Module])) @@ -143,20 +149,23 @@ (-> Text (List [Text Global]) (List [Text Global])) (!push source reference (case head - (#.Left _) - (undefined) - - (#.Right [exported? frames_type frames_anns frames_value]) - (#.Right [exported? - frames_type - frames_anns - (let [current_frames (:as (Stack Frame) frames_value)] - (case (..pop current_frames) - (#.Some current_frames') - current_frames' - - #.None - current_frames))])))) + (#.Definition [exported? frames_type frames_anns frames_value]) + (#.Definition [exported? + frames_type + frames_anns + (let [current_frames (:as (Stack Frame) frames_value)] + (case (..pop current_frames) + (#.Some current_frames') + current_frames' + + #.None + current_frames))]) + + (^or (#.Type _) + (#.Alias _) + (#.Label _) + (#.Slot _)) + (undefined)))) (def: (pop_frame [module_reference definition_reference] source) (-> Name (List [Text Module]) (List [Text Module])) diff --git a/stdlib/source/test/lux/macro.lux b/stdlib/source/test/lux/macro.lux index 2e8c199b4..fa117e96b 100644 --- a/stdlib/source/test/lux/macro.lux +++ b/stdlib/source/test/lux/macro.lux @@ -79,8 +79,6 @@ (!global /.log_expansion!) (!global /.log_full_expansion!))) #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}] [current_module @@ -91,8 +89,6 @@ (!global ..pow/4) (!global ..repeated))) #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}]) #.scopes (list) diff --git a/stdlib/source/test/lux/meta.lux b/stdlib/source/test/lux/meta.lux index 7d397e5d5..9e0175947 100644 --- a/stdlib/source/test/lux/meta.lux +++ b/stdlib/source/test/lux/meta.lux @@ -183,16 +183,12 @@ #.module_aliases (list) #.definitions (list) #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active} expected_module {#.module_hash 0 #.module_aliases (list) #.definitions (list) #.imports (list imported_module_name) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active} expected_modules (list [expected_current_module @@ -384,8 +380,6 @@ #.module_aliases (list) #.definitions current_globals #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}] [expected_macro_module @@ -393,8 +387,6 @@ #.module_aliases (list) #.definitions macro_globals #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}]) #.scopes (list) @@ -506,8 +498,6 @@ #.module_aliases (list) #.definitions current_globals #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}] [expected_macro_module @@ -515,8 +505,6 @@ #.module_aliases (list) #.definitions macro_globals #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}]) #.scopes (list) @@ -655,19 +643,22 @@ (random.ascii/upper 1)) .let [random_tag (\ ! each (|>> [tag_module]) - (random.ascii/upper 1))] - all_tags (|> random_tag - (random.set name.hash 10) - (\ ! each set.list)) - .let [tags_0 (list.first 5 all_tags) - tags_1 (list.after 5 all_tags) - - type_0 (#.Primitive name_0 (list)) + (random.ascii/upper 1)) + random_labels (: (Random [Text (List Text)]) + (do ! + [head (random.ascii/lower 5)] + (|> (random.ascii/lower 5) + (random.only (|>> (text\= head) not)) + (random.set text.hash 3) + (\ ! each set.list) + (random.and (in head)))))] + tags_0 random_labels + tags_1 (let [set/0 (set.of_list text.hash (#.Item tags_0))] + (random.only (|>> #.Item (list.any? (set.member? set/0))not) + random_labels)) + .let [type_0 (#.Primitive name_0 (list)) type_1 (#.Primitive name_1 (list)) - entry_0 [name_0 [tags_0 false type_0]] - entry_1 [name_1 [tags_1 true type_1]] - expected_lux (: Lux {#.info {#.target "" @@ -681,24 +672,23 @@ #.module_aliases (list) #.definitions (list) #.imports (list tag_module) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}] [tag_module {#.module_hash 0 #.module_aliases (list) - #.definitions (list) + #.definitions (list& [name_0 (#.Type [false type_0 (#.Left tags_0)])] + [name_1 (#.Type [true type_1 (#.Right tags_1)])] + ($_ list\composite + (|> (#.Item tags_0) + list.enumeration + (list\each (function (_ [index short]) + [(format "#" short) (#.Label [false type_0 (#.Item tags_0) index])]))) + (|> (#.Item tags_1) + list.enumeration + (list\each (function (_ [index short]) + [(format "#" short) (#.Slot [true type_1 (#.Item tags_1) index])]))))) #.imports (list) - #.tags (list\composite (|> tags_0 - list.enumeration - (list\each (function (_ [index [_ short]]) - [short [index tags_0 false type_0]]))) - (|> tags_1 - list.enumeration - (list\each (function (_ [index [_ short]]) - [short [index tags_1 true type_1]])))) - #.types (list entry_0 entry_1) #.module_annotations #.None #.module_state #.Active}]) #.scopes (list) @@ -719,28 +709,29 @@ type.equivalence))] (|> (/.tag_lists tag_module) (/.result expected_lux) - (try\each (\ equivalence = (list [tags_1 type_1]))) + (try\each (\ equivalence = (list [(list\each (|>> [tag_module]) (#.Item tags_1)) + type_1]))) (try.else false)))) (_.cover [/.tags_of] (|> (/.tags_of [tag_module name_1]) (/.result expected_lux) - (try\each (\ (maybe.equivalence (list.equivalence name.equivalence)) = (#.Some tags_1))) + (try\each (\ (maybe.equivalence (list.equivalence name.equivalence)) = (#.Some (list\each (|>> [tag_module]) (#.Item tags_1))))) (try.else false))) (_.cover [/.tag] - (|> tags_1 + (|> (#.Item tags_1) list.enumeration (list.every? (function (_ [expected_index tag]) - (|> tag + (|> [tag_module tag] /.tag (/.result expected_lux) - (!expect (^multi (^ (#try.Success [actual_index actual_tags actual_type])) + (!expect (^multi (#try.Success [actual_index actual_tags actual_type]) (let [correct_index! (n.= expected_index actual_index) correct_tags! (\ (list.equivalence name.equivalence) = - tags_1 + (list\each (|>> [tag_module]) (#.Item tags_1)) actual_tags) correct_type! @@ -748,7 +739,8 @@ actual_type)] (and correct_index! correct_tags! - correct_type!))))))))) + correct_type!)))) + ))))) ))) (def: locals_related @@ -807,8 +799,6 @@ #.module_aliases (list) #.definitions globals #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}]) #.scopes scopes diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux index 9494096f2..6dd299f2c 100644 --- a/stdlib/source/test/lux/target/jvm.lux +++ b/stdlib/source/test/lux/target/jvm.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Type type primitive int) + [lux (#- Type Label type primitive int) ["." ffi (#+ import:)] ["@" target] [abstract |