diff options
| author | Eduardo Julián | 2021-07-14 14:44:53 -0400 |
|---|---|---|
| committer | GitHub | 2021-07-14 14:44:53 -0400 |
| commit | 89ca40f2f101b2b38187eab5cf905371cd47eb57 (patch) | |
| tree | f05fd1677a70988c6b39c07e52d031d86eff28f1 /stdlib/source/library/lux.lux | |
| parent | 2431e767a09894c2f685911ba7f1ba0b7de2a165 (diff) | |
| parent | 8252bdb938a0284dd12e7365b4eb84b5357bacac (diff) | |
Merge pull request #58 from LuxLang/hierarchy_normalization
Hierarchy normalization
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/library/lux.lux | 5958 |
1 files changed, 5958 insertions, 0 deletions
diff --git a/stdlib/source/library/lux.lux b/stdlib/source/library/lux.lux new file mode 100644 index 000000000..9b01303ea --- /dev/null +++ b/stdlib/source/library/lux.lux @@ -0,0 +1,5958 @@ +("lux def" dummy_location + ["" 0 0] + [["" 0 0] (9 #1 (0 #0))] + #0) + +("lux def" double_quote + ("lux i64 char" +34) + [dummy_location (9 #1 (0 #0))] + #0) + +("lux def" \n + ("lux i64 char" +10) + [dummy_location (9 #1 (0 #0))] + #0) + +("lux def" __paragraph + ("lux text concat" \n \n) + [dummy_location (9 #1 (0 #0))] + #0) + +("lux def" prelude_module + "library/lux" + [dummy_location (9 #1 (0 #0))] + #1) + +## (type: Any +## (Ex [a] a)) +("lux def" Any + ("lux type check type" + (9 #1 ["library/lux" "Any"] + (8 #0 (0 #0) (4 #0 1)))) + [dummy_location + (9 #1 (0 #1 [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 ("lux text concat" + ("lux text concat" "The type of things whose type is irrelevant." __paragraph) + "It can be used to write functions or data-structures that can take, or return, anything."))]] + (0 #0)))] + #1) + +## (type: Nothing +## (All [a] a)) +("lux def" Nothing + ("lux type check type" + (9 #1 ["library/lux" "Nothing"] + (7 #0 (0 #0) (4 #0 1)))) + [dummy_location + (9 #1 (0 #1 [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 ("lux text concat" + ("lux text concat" "The type of things whose type is undefined." __paragraph) + "Useful for expressions that cause errors or other 'extraordinary' conditions."))]] + (0 #0)))] + #1) + +## (type: (List a) +## #Nil +## (#Cons a (List a))) +("lux def type tagged" List + (9 #1 ["library/lux" "List"] + (7 #0 (0 #0) + (1 #0 ## "lux.Nil" + Any + ## "lux.Cons" + (2 #0 (4 #0 1) + (9 #0 (4 #0 1) (4 #0 0)))))) + [dummy_location + (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 #1 [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "A potentially empty list of values.")]] + (0 #0))))] + ["Nil" "Cons"] + #1) + +("lux def" Bit + ("lux type check type" + (9 #1 ["library/lux" "Bit"] + (0 #0 "#Bit" #Nil))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "Your standard, run-of-the-mill boolean values (as bits).")]] + #Nil))] + #1) + +("lux def" I64 + ("lux type check type" + (9 #1 ["library/lux" "I64"] + (7 #0 (0 #0) + (0 #0 "#I64" (#Cons (4 #0 1) #Nil))))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "64-bit integers without any semantics.")]] + #Nil))] + #1) + +("lux def" Nat + ("lux type check type" + (9 #1 ["library/lux" "Nat"] + (0 #0 "#I64" (#Cons (0 #0 "#Nat" #Nil) #Nil)))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 ("lux text concat" + ("lux text concat" "Natural numbers (unsigned integers)." __paragraph) + "They start at zero (0) and extend in the positive direction."))]] + #Nil))] + #1) + +("lux def" Int + ("lux type check type" + (9 #1 ["library/lux" "Int"] + (0 #0 "#I64" (#Cons (0 #0 "#Int" #Nil) #Nil)))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "Your standard, run-of-the-mill integer numbers.")]] + #Nil))] + #1) + +("lux def" Rev + ("lux type check type" + (9 #1 ["library/lux" "Rev"] + (0 #0 "#I64" (#Cons (0 #0 "#Rev" #Nil) #Nil)))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 ("lux text concat" + ("lux text concat" "Fractional numbers that live in the interval [0,1)." __paragraph) + "Useful for probability, and other domains that work within that interval."))]] + #Nil))] + #1) + +("lux def" Frac + ("lux type check type" + (9 #1 ["library/lux" "Frac"] + (0 #0 "#Frac" #Nil))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "Your standard, run-of-the-mill floating-point (fractional) numbers.")]] + #Nil))] + #1) + +("lux def" Text + ("lux type check type" + (9 #1 ["library/lux" "Text"] + (0 #0 "#Text" #Nil))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "Your standard, run-of-the-mill string values.")]] + #Nil))] + #1) + +("lux def" Name + ("lux type check type" + (9 #1 ["library/lux" "Name"] + (2 #0 Text Text))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "A name. It is used as part of Lux syntax to represent identifiers and tags.")]] + #Nil))] + #1) + +## (type: (Maybe a) +## #None +## (#Some a)) +("lux def type tagged" Maybe + (9 #1 ["library/lux" "Maybe"] + (7 #0 #Nil + (1 #0 ## "lux.None" + Any + ## "lux.Some" + (4 #0 1)))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "type-args"])] + [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "a")] #Nil))]] + (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "A potentially missing value.")]] + #Nil)))] + ["None" "Some"] + #1) + +## (type: #rec Type +## (#Primitive Text (List Type)) +## (#Sum Type Type) +## (#Product Type Type) +## (#Function Type Type) +## (#Parameter Nat) +## (#Var Nat) +## (#Ex Nat) +## (#UnivQ (List Type) Type) +## (#ExQ (List Type) Type) +## (#Apply Type Type) +## (#Named Name Type) +## ) +("lux def type tagged" Type + (9 #1 ["library/lux" "Type"] + ({Type + ({Type_List + ({Type_Pair + (9 #0 Nothing + (7 #0 #Nil + (1 #0 ## "lux.Primitive" + (2 #0 Text Type_List) + (1 #0 ## "lux.Sum" + Type_Pair + (1 #0 ## "lux.Product" + Type_Pair + (1 #0 ## "lux.Function" + Type_Pair + (1 #0 ## "lux.Parameter" + Nat + (1 #0 ## "lux.Var" + Nat + (1 #0 ## "lux.Ex" + Nat + (1 #0 ## "lux.UnivQ" + (2 #0 Type_List Type) + (1 #0 ## "lux.ExQ" + (2 #0 Type_List Type) + (1 #0 ## "lux.Apply" + Type_Pair + ## "lux.Named" + (2 #0 Name Type)))))))))))))} + ("lux type check type" (2 #0 Type Type)))} + ("lux type check type" (9 #0 Type List)))} + ("lux type check type" (9 #0 (4 #0 1) (4 #0 0))))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "This type represents the data-structures that are used to specify types themselves.")]] + (#Cons [[dummy_location (7 #0 ["library/lux" "type-rec?"])] + [dummy_location (0 #0 #1)]] + #Nil)))] + ["Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named"] + #1) + +## (type: Location +## {#module Text +## #line Nat +## #column Nat}) +("lux def type tagged" Location + (#Named ["library/lux" "Location"] + (#Product Text (#Product Nat Nat))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "Locations are for specifying the location of Code nodes in Lux files during compilation.")]] + #Nil))] + ["module" "line" "column"] + #1) + +## (type: (Ann m v) +## {#meta m +## #datum v}) +("lux def type tagged" Ann + (#Named ["library/lux" "Ann"] + (#UnivQ #Nil + (#UnivQ #Nil + (#Product (#Parameter 3) + (#Parameter 1))))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "The type of things that can be annotated with meta-data of arbitrary types.")]] + (#Cons [[dummy_location (7 #0 ["library/lux" "type-args"])] + [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "m")] (#Cons [dummy_location (5 #0 "v")] #Nil)))]] + #Nil)))] + ["meta" "datum"] + #1) + +## (type: (Code' w) +## (#Bit Bit) +## (#Nat Nat) +## (#Int Int) +## (#Rev Rev) +## (#Frac Frac) +## (#Text Text) +## (#Identifier Name) +## (#Tag Name) +## (#Form (List (w (Code' w)))) +## (#Tuple (List (w (Code' w)))) +## (#Record (List [(w (Code' w)) (w (Code' w))]))) +("lux def type tagged" Code' + (#Named ["library/lux" "Code'"] + ({Code + ({Code_List + (#UnivQ #Nil + (#Sum ## "lux.Bit" + Bit + (#Sum ## "lux.Nat" + Nat + (#Sum ## "lux.Int" + Int + (#Sum ## "lux.Rev" + Rev + (#Sum ## "lux.Frac" + Frac + (#Sum ## "lux.Text" + Text + (#Sum ## "lux.Identifier" + Name + (#Sum ## "lux.Tag" + Name + (#Sum ## "lux.Form" + Code_List + (#Sum ## "lux.Tuple" + Code_List + ## "lux.Record" + (#Apply (#Product Code Code) List) + )))))))))) + )} + ("lux type check type" (#Apply Code List)))} + ("lux type check type" (#Apply (#Apply (#Parameter 1) + (#Parameter 0)) + (#Parameter 1))))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "type-args"])] + [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "w")] #Nil))]] + #Nil))] + ["Bit" "Nat" "Int" "Rev" "Frac" "Text" "Identifier" "Tag" "Form" "Tuple" "Record"] + #1) + +## (type: Code +## (Ann Location (Code' (Ann Location)))) +("lux def" Code + (#Named ["library/lux" "Code"] + ({w + (#Apply (#Apply w Code') w)} + ("lux type check type" (#Apply Location Ann)))) + [dummy_location + (#Record (#Cons [[dummy_location (#Tag ["library/lux" "doc"])] + [dummy_location (#Text "The type of Code nodes for Lux syntax.")]] + #Nil))] + #1) + +("lux def" _ann + ("lux type check" + (#Function (#Apply (#Apply Location Ann) + Code') + Code) + ([_ data] + [dummy_location data])) + [dummy_location (#Record #Nil)] + #0) + +("lux def" bit$ + ("lux type check" (#Function Bit Code) + ([_ value] (_ann (#Bit value)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" nat$ + ("lux type check" (#Function Nat Code) + ([_ value] (_ann (#Nat value)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" int$ + ("lux type check" (#Function Int Code) + ([_ value] (_ann (#Int value)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" rev$ + ("lux type check" (#Function Rev Code) + ([_ value] (_ann (#Rev value)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" frac$ + ("lux type check" (#Function Frac Code) + ([_ value] (_ann (#Frac value)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" text$ + ("lux type check" (#Function Text Code) + ([_ text] (_ann (#Text text)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" identifier$ + ("lux type check" (#Function Name Code) + ([_ name] (_ann (#Identifier name)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" local_identifier$ + ("lux type check" (#Function Text Code) + ([_ name] (_ann (#Identifier ["" name])))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" tag$ + ("lux type check" (#Function Name Code) + ([_ name] (_ann (#Tag name)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" local_tag$ + ("lux type check" (#Function Text Code) + ([_ name] (_ann (#Tag ["" name])))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" form$ + ("lux type check" (#Function (#Apply Code List) Code) + ([_ tokens] (_ann (#Form tokens)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" tuple$ + ("lux type check" (#Function (#Apply Code List) Code) + ([_ tokens] (_ann (#Tuple tokens)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" record$ + ("lux type check" (#Function (#Apply (#Product Code Code) List) Code) + ([_ tokens] (_ann (#Record tokens)))) + [dummy_location (#Record #Nil)] + #0) + +## (type: Definition +## [Bit Type Code Any]) +("lux def" Definition + ("lux type check type" + (#Named ["library/lux" "Definition"] + (#Product Bit (#Product Type (#Product Code Any))))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "Represents all the data associated with a definition: its type, its annotations, and its value.")] + #Nil)) + #1) + +## (type: Alias +## Name) +("lux def" Alias + ("lux type check type" + (#Named ["library/lux" "Alias"] + Name)) + (record$ #Nil) + #1) + +## (type: Global +## (#Alias Alias) +## (#Definition Definition)) +("lux def type tagged" Global + (#Named ["library/lux" "Global"] + (#Sum Alias + Definition)) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "Represents all the data associated with a global constant.")] + #Nil)) + ["Alias" "Definition"] + #1) + +## (type: (Bindings k v) +## {#counter Nat +## #mappings (List [k v])}) +("lux def type tagged" Bindings + (#Named ["library/lux" "Bindings"] + (#UnivQ #Nil + (#UnivQ #Nil + (#Product ## "lux.counter" + Nat + ## "lux.mappings" + (#Apply (#Product (#Parameter 3) + (#Parameter 1)) + List))))) + (record$ (#Cons [(tag$ ["library/lux" "type-args"]) + (tuple$ (#Cons (text$ "k") (#Cons (text$ "v") #Nil)))] + #Nil)) + ["counter" "mappings"] + #1) + +## (type: #export Ref +## (#Local Nat) +## (#Captured Nat)) +("lux def type tagged" Ref + (#Named ["library/lux" "Ref"] + (#Sum ## Local + Nat + ## Captured + Nat)) + (record$ #Nil) + ["Local" "Captured"] + #1) + +## (type: Scope +## {#name (List Text) +## #inner Nat +## #locals (Bindings Text [Type Nat]) +## #captured (Bindings Text [Type Ref])}) +("lux def type tagged" Scope + (#Named ["library/lux" "Scope"] + (#Product ## name + (#Apply Text List) + (#Product ## inner + Nat + (#Product ## locals + (#Apply (#Product Type Nat) (#Apply Text Bindings)) + ## captured + (#Apply (#Product Type Ref) (#Apply Text Bindings)))))) + (record$ #Nil) + ["name" "inner" "locals" "captured"] + #1) + +("lux def" Code_List + ("lux type check type" + (#Apply Code List)) + (record$ #Nil) + #0) + +## (type: (Either l r) +## (#Left l) +## (#Right r)) +("lux def type tagged" Either + (#Named ["library/lux" "Either"] + (#UnivQ #Nil + (#UnivQ #Nil + (#Sum ## "lux.Left" + (#Parameter 3) + ## "lux.Right" + (#Parameter 1))))) + (record$ (#Cons [(tag$ ["library/lux" "type-args"]) + (tuple$ (#Cons (text$ "l") (#Cons (text$ "r") #Nil)))] + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "A choice between two values of different types.")] + #Nil))) + ["Left" "Right"] + #1) + +## (type: Source +## [Location Nat Text]) +("lux def" Source + ("lux type check type" + (#Named ["library/lux" "Source"] + (#Product Location (#Product Nat Text)))) + (record$ #Nil) + #1) + +## (type: Module_State +## #Active +## #Compiled +## #Cached) +("lux def type tagged" Module_State + (#Named ["library/lux" "Module_State"] + (#Sum + ## #Active + Any + (#Sum + ## #Compiled + Any + ## #Cached + Any))) + (record$ #Nil) + ["Active" "Compiled" "Cached"] + #1) + +## (type: 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}) +("lux def type tagged" Module + (#Named ["library/lux" "Module"] + (#Product ## "lux.module_hash" + Nat + (#Product ## "lux.module_aliases" + (#Apply (#Product Text Text) List) + (#Product ## "lux.definitions" + (#Apply (#Product Text Global) List) + (#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)) + )))))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "All the information contained within a Lux module.")] + #Nil)) + ["module_hash" "module_aliases" "definitions" "imports" "tags" "types" "module_annotations" "module_state"] + #1) + +## (type: Type_Context +## {#ex_counter Nat +## #var_counter Nat +## #var_bindings (List [Nat (Maybe Type)])}) +("lux def type tagged" Type_Context + (#Named ["library/lux" "Type_Context"] + (#Product ## ex_counter + Nat + (#Product ## var_counter + Nat + ## var_bindings + (#Apply (#Product Nat (#Apply Type Maybe)) + List)))) + (record$ #Nil) + ["ex_counter" "var_counter" "var_bindings"] + #1) + +## (type: Mode +## #Build +## #Eval +## #Interpreter) +("lux def type tagged" Mode + (#Named ["library/lux" "Mode"] + (#Sum ## Build + Any + (#Sum ## Eval + Any + ## Interpreter + Any))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "A sign that shows the conditions under which the compiler is running.")] + #Nil)) + ["Build" "Eval" "Interpreter"] + #1) + +## (type: Info +## {#target Text +## #version Text +## #mode Mode}) +("lux def type tagged" Info + (#Named ["library/lux" "Info"] + (#Product + ## target + Text + (#Product + ## version + Text + ## mode + Mode))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "Information about the current version and type of compiler that is running.")] + #Nil)) + ["target" "version" "mode"] + #1) + +## (type: Lux +## {#info Info +## #source Source +## #location Location +## #current_module (Maybe Text) +## #modules (List [Text Module]) +## #scopes (List Scope) +## #type_context Type_Context +## #expected (Maybe Type) +## #seed Nat +## #scope_type_vars (List Nat) +## #extensions Any +## #host Any}) +("lux def type tagged" Lux + (#Named ["library/lux" "Lux"] + (#Product ## "lux.info" + Info + (#Product ## "lux.source" + Source + (#Product ## "lux.location" + Location + (#Product ## "lux.current_module" + (#Apply Text Maybe) + (#Product ## "lux.modules" + (#Apply (#Product Text Module) List) + (#Product ## "lux.scopes" + (#Apply Scope List) + (#Product ## "lux.type_context" + Type_Context + (#Product ## "lux.expected" + (#Apply Type Maybe) + (#Product ## "lux.seed" + Nat + (#Product ## scope_type_vars + (#Apply Nat List) + (#Product ## extensions + Any + ## "lux.host" + Any)))))))))))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "Represents the state of the Lux compiler during a run." __paragraph) + ("lux text concat" + ("lux text concat" "It is provided to macros during their invocation, so they can access compiler data." __paragraph) + "Caveat emptor: Avoid fiddling with it, unless you know what you're doing.")))] + #Nil)) + ["info" "source" "location" "current_module" "modules" "scopes" "type_context" "expected" "seed" "scope_type_vars" "extensions" "host"] + #1) + +## (type: (Meta a) +## (-> Lux (Either Text [Lux a]))) +("lux def" Meta + ("lux type check type" + (#Named ["library/lux" "Meta"] + (#UnivQ #Nil + (#Function Lux + (#Apply (#Product Lux (#Parameter 1)) + (#Apply Text Either)))))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "Computations that can have access to the state of the compiler." __paragraph) + "These computations may fail, or modify the state of the compiler."))] + (#Cons [(tag$ ["library/lux" "type-args"]) + (tuple$ (#Cons (text$ "a") #Nil))] + #Nil))) + #1) + +## (type: Macro' +## (-> (List Code) (Meta (List Code)))) +("lux def" Macro' + ("lux type check type" + (#Named ["library/lux" "Macro'"] + (#Function Code_List (#Apply Code_List Meta)))) + (record$ #Nil) + #1) + +## (type: Macro +## (primitive "#Macro")) +("lux def" Macro + ("lux type check type" + (#Named ["library/lux" "Macro"] + (#Primitive "#Macro" #Nil))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "Functions that run at compile-time and allow you to transform and extend the language in powerful ways.")] + #Nil)) + #1) + +## Base functions & macros +("lux def" return + ("lux type check" + (#UnivQ #Nil + (#Function (#Parameter 1) + (#Function Lux + (#Apply (#Product Lux + (#Parameter 1)) + (#Apply Text Either))))) + ([_ val] + ([_ state] + (#Right state val)))) + (record$ #Nil) + #0) + +("lux def" fail + ("lux type check" + (#UnivQ #Nil + (#Function Text + (#Function Lux + (#Apply (#Product Lux + (#Parameter 1)) + (#Apply Text Either))))) + ([_ msg] + ([_ state] + (#Left msg)))) + (record$ #Nil) + #0) + +("lux def" let'' + ("lux macro" + ([_ tokens] + ({(#Cons lhs (#Cons rhs (#Cons body #Nil))) + (return (#Cons (form$ (#Cons (record$ (#Cons [lhs body] #Nil)) (#Cons rhs #Nil))) + #Nil)) + + _ + (fail "Wrong syntax for let''")} + tokens))) + (record$ #.Nil) + #0) + +("lux def" function'' + ("lux macro" + ([_ tokens] + ({(#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil)) + (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" ""])) + (#Cons arg #Nil)))) + (#Cons ({#Nil + body + + _ + (_ann (#Form (#Cons (_ann (#Identifier ["library/lux" "function''"])) + (#Cons (_ann (#Tuple args')) + (#Cons body #Nil)))))} + args') + #Nil)))) + #Nil)) + + (#Cons [_ (#Identifier ["" self])] (#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil))) + (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" self])) + (#Cons arg #Nil)))) + (#Cons ({#Nil + body + + _ + (_ann (#Form (#Cons (_ann (#Identifier ["library/lux" "function''"])) + (#Cons (_ann (#Tuple args')) + (#Cons body #Nil)))))} + args') + #Nil)))) + #Nil)) + + _ + (fail "Wrong syntax for function''")} + tokens))) + (record$ #.Nil) + #0) + +("lux def" location_code + ("lux type check" Code + (tuple$ (#Cons (text$ "") (#Cons (nat$ 0) (#Cons (nat$ 0) #Nil))))) + (record$ #Nil) + #0) + +("lux def" meta_code + ("lux type check" (#Function Name (#Function Code Code)) + ([_ tag] + ([_ value] + (tuple$ (#Cons location_code + (#Cons (form$ (#Cons (tag$ tag) (#Cons value #Nil))) + #Nil)))))) + (record$ #Nil) + #0) + +("lux def" flag_meta + ("lux type check" (#Function Text Code) + ([_ tag] + (tuple$ (#Cons [(meta_code ["library/lux" "Tag"] (tuple$ (#Cons (text$ "library/lux") (#Cons (text$ tag) #Nil)))) + (#Cons [(meta_code ["library/lux" "Bit"] (bit$ #1)) + #Nil])])))) + (record$ #Nil) + #0) + +("lux def" doc_meta + ("lux type check" (#Function Text (#Product Code Code)) + (function'' [doc] [(tag$ ["library/lux" "doc"]) (text$ doc)])) + (record$ #Nil) + #0) + +("lux def" as_def + ("lux type check" (#Function Code (#Function Code (#Function Code (#Function Bit Code)))) + (function'' [name value annotations exported?] + (form$ (#Cons (text$ "lux def") (#Cons name (#Cons value (#Cons annotations (#Cons (bit$ exported?) #Nil)))))))) + (record$ #Nil) + #0) + +("lux def" as_checked + ("lux type check" (#Function Code (#Function Code Code)) + (function'' [type value] + (form$ (#Cons (text$ "lux type check") (#Cons type (#Cons value #Nil)))))) + (record$ #Nil) + #0) + +("lux def" as_function + ("lux type check" (#Function Code (#Function (#Apply Code List) (#Function Code Code))) + (function'' [self inputs output] + (form$ (#Cons (identifier$ ["library/lux" "function''"]) + (#Cons self + (#Cons (tuple$ inputs) + (#Cons output #Nil))))))) + (record$ #Nil) + #0) + +("lux def" as_macro + ("lux type check" (#Function Code Code) + (function'' [expression] + (form$ (#Cons (text$ "lux macro") + (#Cons expression + #Nil))))) + (record$ #Nil) + #0) + +("lux def" def:'' + ("lux macro" + (function'' [tokens] + ({(#Cons [[_ (#Tag ["" "export"])] + (#Cons [[_ (#Form (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (#Cons [(as_def name (as_checked type (as_function name args body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + #1) + #Nil])) + + (#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (#Cons [(as_def name (as_checked type body) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + #1) + #Nil])) + + (#Cons [[_ (#Form (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(as_def name (as_checked type (as_function name args body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + #0) + #Nil])) + + (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(as_def name (as_checked type body) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + #0) + #Nil])) + + _ + (fail "Wrong syntax for def''")} + tokens))) + (record$ #.Nil) + #0) + +("lux def" macro:' + ("lux macro" + (function'' [tokens] + ({(#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil)) + (return (#Cons (as_def name (as_macro (as_function name args body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons (tag$ ["library/lux" "Nil"]) + #Nil))) + #0) + #Nil)) + + (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil))) + (return (#Cons (as_def name (as_macro (as_function name args body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons (tag$ ["library/lux" "Nil"]) + #Nil))) + #1) + #Nil)) + + (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons meta_data (#Cons body #Nil)))) + (return (#Cons (as_def name (as_macro (as_function name args body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta_data + #Nil))) + #1) + #Nil)) + + _ + (fail "Wrong syntax for macro:'")} + tokens))) + (record$ #.Nil) + #0) + +(macro:' #export (comment tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Throws away any code given to it." __paragraph) + ("lux text concat" + ("lux text concat" "## Great for commenting-out code, while retaining syntax high-lighting and formatting in your text editor." __paragraph) + "(comment +1 +2 +3 +4)")))] + #Nil) + (return #Nil)) + +(macro:' ($' tokens) + ({(#Cons x #Nil) + (return tokens) + + (#Cons x (#Cons y xs)) + (return (#Cons (form$ (#Cons (identifier$ ["library/lux" "$'"]) + (#Cons (form$ (#Cons (tag$ ["library/lux" "Apply"]) + (#Cons y (#Cons x #Nil)))) + xs))) + #Nil)) + + _ + (fail "Wrong syntax for $'")} + tokens)) + +(def:'' (list\map f xs) + #Nil + (#UnivQ #Nil + (#UnivQ #Nil + (#Function (#Function (#Parameter 3) (#Parameter 1)) + (#Function ($' List (#Parameter 3)) + ($' List (#Parameter 1)))))) + ({#Nil + #Nil + + (#Cons x xs') + (#Cons (f x) (list\map f xs'))} + xs)) + +(def:'' RepEnv + #Nil + Type + ($' List (#Product Text Code))) + +(def:'' (make_env xs ys) + #Nil + (#Function ($' List Text) (#Function ($' List Code) RepEnv)) + ({[(#Cons x xs') (#Cons y ys')] + (#Cons [x y] (make_env xs' ys')) + + _ + #Nil} + [xs ys])) + +(def:'' (text\= reference sample) + #Nil + (#Function Text (#Function Text Bit)) + ("lux text =" reference sample)) + +(def:'' (get_rep key env) + #Nil + (#Function Text (#Function RepEnv ($' Maybe Code))) + ({#Nil + #None + + (#Cons [k v] env') + ({#1 + (#Some v) + + #0 + (get_rep key env')} + (text\= k key))} + env)) + +(def:'' (replace_syntax reps syntax) + #Nil + (#Function RepEnv (#Function Code Code)) + ({[_ (#Identifier "" name)] + ({(#Some replacement) + replacement + + #None + syntax} + (get_rep name reps)) + + [meta (#Form parts)] + [meta (#Form (list\map (replace_syntax reps) parts))] + + [meta (#Tuple members)] + [meta (#Tuple (list\map (replace_syntax reps) members))] + + [meta (#Record slots)] + [meta (#Record (list\map ("lux type check" (#Function (#Product Code Code) (#Product Code Code)) + (function'' [slot] + ({[k v] + [(replace_syntax reps k) (replace_syntax reps v)]} + slot))) + slots))] + + _ + syntax} + syntax)) + +(def:'' (n/* param subject) + (#.Cons (doc_meta "Nat(ural) multiplication.") #.Nil) + (#Function Nat (#Function Nat Nat)) + ("lux type as" Nat + ("lux i64 *" + ("lux type as" Int param) + ("lux type as" Int subject)))) + +(def:'' (update_parameters code) + #Nil + (#Function Code Code) + ({[_ (#Tuple members)] + (tuple$ (list\map update_parameters members)) + + [_ (#Record pairs)] + (record$ (list\map ("lux type check" (#Function (#Product Code Code) (#Product Code Code)) + (function'' [pair] + (let'' [name val] pair + [name (update_parameters val)]))) + pairs)) + + [_ (#Form (#Cons [_ (#Tag "library/lux" "Parameter")] (#Cons [_ (#Nat idx)] #Nil)))] + (form$ (#Cons (tag$ ["library/lux" "Parameter"]) (#Cons (nat$ ("lux i64 +" 2 idx)) #Nil))) + + [_ (#Form members)] + (form$ (list\map update_parameters members)) + + _ + code} + code)) + +(def:'' (parse_quantified_args args next) + #Nil + ## (-> (List Code) (-> (List Text) (Meta (List Code))) (Meta (List Code))) + (#Function ($' List Code) + (#Function (#Function ($' List Text) (#Apply ($' List Code) Meta)) + (#Apply ($' List Code) Meta) + )) + ({#Nil + (next #Nil) + + (#Cons [_ (#Identifier "" arg_name)] args') + (parse_quantified_args args' (function'' [names] (next (#Cons arg_name names)))) + + _ + (fail "Expected identifier.")} + args)) + +(def:'' (make_parameter idx) + #Nil + (#Function Nat Code) + (form$ (#Cons (tag$ ["library/lux" "Parameter"]) (#Cons (nat$ idx) #Nil)))) + +(def:'' (list\fold f init xs) + #Nil + ## (All [a b] (-> (-> b a a) a (List b) a)) + (#UnivQ #Nil (#UnivQ #Nil (#Function (#Function (#Parameter 1) + (#Function (#Parameter 3) + (#Parameter 3))) + (#Function (#Parameter 3) + (#Function ($' List (#Parameter 1)) + (#Parameter 3)))))) + ({#Nil + init + + (#Cons x xs') + (list\fold f (f x init) xs')} + xs)) + +(def:'' (list\size list) + #Nil + (#UnivQ #Nil + (#Function ($' List (#Parameter 1)) Nat)) + (list\fold (function'' [_ acc] ("lux i64 +" 1 acc)) 0 list)) + +(macro:' #export (All tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Universal quantification." __paragraph) + ("lux text concat" + ("lux text concat" "(All [a] (-> a a))" __paragraph) + ("lux text concat" + ("lux text concat" "## A name can be provided, to specify a recursive type." __paragraph) + "(All List [a] (| Any [a (List a)]))"))))] + #Nil) + (let'' [self_name tokens] ({(#Cons [_ (#Identifier "" self_name)] tokens) + [self_name tokens] + + _ + ["" tokens]} + tokens) + ({(#Cons [_ (#Tuple args)] (#Cons body #Nil)) + (parse_quantified_args args + (function'' [names] + (let'' body' (list\fold ("lux type check" (#Function Text (#Function Code Code)) + (function'' [name' body'] + (form$ (#Cons (tag$ ["library/lux" "UnivQ"]) + (#Cons (tag$ ["library/lux" "Nil"]) + (#Cons (replace_syntax (#Cons [name' (make_parameter 1)] #Nil) + (update_parameters body')) #Nil)))))) + body + names) + (return (#Cons ({[#1 _] + body' + + [_ #Nil] + body' + + [#0 _] + (replace_syntax (#Cons [self_name (make_parameter (n/* 2 ("lux i64 -" 1 (list\size names))))] + #Nil) + body')} + [(text\= "" self_name) names]) + #Nil))))) + + _ + (fail "Wrong syntax for All")} + tokens))) + +(macro:' #export (Ex tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Existential quantification." __paragraph) + ("lux text concat" + ("lux text concat" "(Ex [a] [(Codec Text a) a])" __paragraph) + ("lux text concat" + ("lux text concat" "## A name can be provided, to specify a recursive type." __paragraph) + "(Ex Self [a] [(Codec Text a) a (List (Self a))])"))))] + #Nil) + (let'' [self_name tokens] ({(#Cons [_ (#Identifier "" self_name)] tokens) + [self_name tokens] + + _ + ["" tokens]} + tokens) + ({(#Cons [_ (#Tuple args)] (#Cons body #Nil)) + (parse_quantified_args args + (function'' [names] + (let'' body' (list\fold ("lux type check" (#Function Text (#Function Code Code)) + (function'' [name' body'] + (form$ (#Cons (tag$ ["library/lux" "ExQ"]) + (#Cons (tag$ ["library/lux" "Nil"]) + (#Cons (replace_syntax (#Cons [name' (make_parameter 1)] #Nil) + (update_parameters body')) #Nil)))))) + body + names) + (return (#Cons ({[#1 _] + body' + + [_ #Nil] + body' + + [#0 _] + (replace_syntax (#Cons [self_name (make_parameter (n/* 2 ("lux i64 -" 1 (list\size names))))] + #Nil) + body')} + [(text\= "" self_name) names]) + #Nil))))) + + _ + (fail "Wrong syntax for Ex")} + tokens))) + +(def:'' (list\reverse list) + #Nil + (All [a] (#Function ($' List a) ($' List a))) + (list\fold ("lux type check" (All [a] (#Function a (#Function ($' List a) ($' List a)))) + (function'' [head tail] (#Cons head tail))) + #Nil + list)) + +(macro:' #export (-> tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Function types:" __paragraph) + ("lux text concat" + ("lux text concat" "(-> Int Int Int)" __paragraph) + "## This is the type of a function that takes 2 Ints and returns an Int.")))] + #Nil) + ({(#Cons output inputs) + (return (#Cons (list\fold ("lux type check" (#Function Code (#Function Code Code)) + (function'' [i o] (form$ (#Cons (tag$ ["library/lux" "Function"]) (#Cons i (#Cons o #Nil)))))) + output + inputs) + #Nil)) + + _ + (fail "Wrong syntax for ->")} + (list\reverse tokens))) + +(macro:' #export (list xs) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## List-construction macro." __paragraph) + "(list +1 +2 +3)"))] + #Nil) + (return (#Cons (list\fold (function'' [head tail] + (form$ (#Cons (tag$ ["library/lux" "Cons"]) + (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) + #Nil)))) + (tag$ ["library/lux" "Nil"]) + (list\reverse xs)) + #Nil))) + +(macro:' #export (list& xs) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## List-construction macro, with the last element being a tail-list." __paragraph) + ("lux text concat" + ("lux text concat" "## In other words, this macro prepends elements to another list." __paragraph) + "(list& +1 +2 +3 (list +4 +5 +6))")))] + #Nil) + ({(#Cons last init) + (return (list (list\fold (function'' [head tail] + (form$ (list (tag$ ["library/lux" "Cons"]) + (tuple$ (list head tail))))) + last + init))) + + _ + (fail "Wrong syntax for list&")} + (list\reverse xs))) + +(macro:' #export (& tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Tuple types:" __paragraph) + ("lux text concat" + ("lux text concat" "(& Text Int Bit)" __paragraph) + ("lux text concat" + ("lux text concat" "## Any." __paragraph) + "(&)"))))] + #Nil) + ({#Nil + (return (list (identifier$ ["library/lux" "Any"]))) + + (#Cons last prevs) + (return (list (list\fold (function'' [left right] (form$ (list (tag$ ["library/lux" "Product"]) left right))) + last + prevs)))} + (list\reverse tokens))) + +(macro:' #export (| tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Variant types:" __paragraph) + ("lux text concat" + ("lux text concat" "(| Text Int Bit)" __paragraph) + ("lux text concat" + ("lux text concat" "## Nothing." __paragraph) + "(|)"))))] + #Nil) + ({#Nil + (return (list (identifier$ ["library/lux" "Nothing"]))) + + (#Cons last prevs) + (return (list (list\fold (function'' [left right] (form$ (list (tag$ ["library/lux" "Sum"]) left right))) + last + prevs)))} + (list\reverse tokens))) + +(macro:' (function' tokens) + (let'' [name tokens'] ({(#Cons [[_ (#Identifier ["" name])] tokens']) + [name tokens'] + + _ + ["" tokens]} + tokens) + ({(#Cons [[_ (#Tuple args)] (#Cons [body #Nil])]) + ({#Nil + (fail "function' requires a non-empty arguments tuple.") + + (#Cons [harg targs]) + (return (list (form$ (list (tuple$ (list (local_identifier$ name) + harg)) + (list\fold (function'' [arg body'] + (form$ (list (tuple$ (list (local_identifier$ "") + arg)) + body'))) + body + (list\reverse targs))))))} + args) + + _ + (fail "Wrong syntax for function'")} + tokens'))) + +(macro:' (def:''' tokens) + ({(#Cons [[_ (#Tag ["" "export"])] + (#Cons [[_ (#Form (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (list (form$ (list (text$ "lux def") + name + (form$ (list (text$ "lux type check") + type + (form$ (list (identifier$ ["library/lux" "function'"]) + name + (tuple$ args) + body)))) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + (bit$ #1))))) + + (#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (list (form$ (list (text$ "lux def") + name + (form$ (list (text$ "lux type check") + type + body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + (bit$ #1))))) + + (#Cons [[_ (#Form (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (text$ "lux def") + name + (form$ (list (text$ "lux type check") + type + (form$ (list (identifier$ ["library/lux" "function'"]) + name + (tuple$ args) + body)))) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + (bit$ #0))))) + + (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (text$ "lux def") + name + (form$ (list (text$ "lux type check") type body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + (bit$ #0))))) + + _ + (fail "Wrong syntax for def:'''")} + tokens)) + +(def:''' (as_pairs xs) + #Nil + (All [a] (-> ($' List a) ($' List (& a a)))) + ({(#Cons x (#Cons y xs')) + (#Cons [x y] (as_pairs xs')) + + _ + #Nil} + xs)) + +(macro:' (let' tokens) + ({(#Cons [[_ (#Tuple bindings)] (#Cons [body #Nil])]) + (return (list (list\fold ("lux type check" (-> (& Code Code) Code + Code) + (function' [binding body] + ({[label value] + (form$ (list (record$ (list [label body])) value))} + binding))) + body + (list\reverse (as_pairs bindings))))) + + _ + (fail "Wrong syntax for let'")} + tokens)) + +(def:''' (any? p xs) + #Nil + (All [a] + (-> (-> a Bit) ($' List a) Bit)) + ({#Nil + #0 + + (#Cons x xs') + ({#1 #1 + #0 (any? p xs')} + (p x))} + xs)) + +(def:''' (wrap_meta content) + #Nil + (-> Code Code) + (tuple$ (list (tuple$ (list (text$ "") (nat$ 0) (nat$ 0))) + content))) + +(def:''' (untemplate_list tokens) + #Nil + (-> ($' List Code) Code) + ({#Nil + (_ann (#Tag ["library/lux" "Nil"])) + + (#Cons [token tokens']) + (_ann (#Form (list (_ann (#Tag ["library/lux" "Cons"])) token (untemplate_list tokens'))))} + tokens)) + +(def:''' (list\compose xs ys) + #Nil + (All [a] (-> ($' List a) ($' List a) ($' List a))) + ({(#Cons x xs') + (#Cons x (list\compose xs' ys)) + + #Nil + ys} + xs)) + +(def:''' (_$_joiner op a1 a2) + #Nil + (-> Code Code Code Code) + ({[_ (#Form parts)] + (form$ (list\compose parts (list a1 a2))) + + _ + (form$ (list op a1 a2))} + op)) + +(def:''' (function/flip func) + #Nil + (All [a b c] + (-> (-> a b c) (-> b a c))) + (function' [right left] + (func left right))) + +(macro:' #export (_$ tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Left-association for the application of binary functions over variadic arguments." ..\n) + ("lux text concat" + ("lux text concat" "(_$ text\compose ''Hello, '' name ''. How are you?'')" ..\n) + ("lux text concat" + ("lux text concat" "## =>" ..\n) + "(text\compose (text\compose ''Hello, '' name) ''. How are you?'')"))))] + #Nil) + ({(#Cons op tokens') + ({(#Cons first nexts) + (return (list (list\fold (function/flip (_$_joiner op)) first nexts))) + + _ + (fail "Wrong syntax for _$")} + tokens') + + _ + (fail "Wrong syntax for _$")} + tokens)) + +(macro:' #export ($_ tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Right-association for the application of binary functions over variadic arguments." ..\n) + ("lux text concat" + ("lux text concat" "($_ text\compose ''Hello, '' name ''. How are you?'')" ..\n) + ("lux text concat" + ("lux text concat" "## =>" ..\n) + "(text\compose ''Hello, '' (text\compose name ''. How are you?''))"))))] + #Nil) + ({(#Cons op tokens') + ({(#Cons last prevs) + (return (list (list\fold (_$_joiner op) last prevs))) + + _ + (fail "Wrong syntax for $_")} + (list\reverse tokens')) + + _ + (fail "Wrong syntax for $_")} + tokens)) + +## (interface: (Monad m) +## (: (All [a] (-> a (m a))) +## wrap) +## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) +## bind)) +("lux def type tagged" Monad + (#Named ["library/lux" "Monad"] + (All [m] + (& (All [a] (-> a ($' m a))) + (All [a b] (-> (-> a ($' m b)) + ($' m a) + ($' m b)))))) + (record$ (list)) + ["wrap" "bind"] + #0) + +(def:''' maybe_monad + #Nil + ($' Monad Maybe) + {#wrap + (function' [x] (#Some x)) + + #bind + (function' [f ma] + ({#None #None + (#Some a) (f a)} + ma))}) + +(def:''' meta_monad + #Nil + ($' Monad Meta) + {#wrap + (function' [x] + (function' [state] + (#Right state x))) + + #bind + (function' [f ma] + (function' [state] + ({(#Left msg) + (#Left msg) + + (#Right [state' a]) + (f a state')} + (ma state))))}) + +(macro:' (do tokens) + ({(#Cons monad (#Cons [_ (#Tuple bindings)] (#Cons body #Nil))) + (let' [g!wrap (local_identifier$ "wrap") + g!bind (local_identifier$ " bind ") + body' (list\fold ("lux type check" (-> (& Code Code) Code Code) + (function' [binding body'] + (let' [[var value] binding] + ({[_ (#Tag "" "let")] + (form$ (list (identifier$ ["library/lux" "let'"]) value body')) + + _ + (form$ (list g!bind + (form$ (list (tuple$ (list (local_identifier$ "") var)) body')) + value))} + var)))) + body + (list\reverse (as_pairs bindings)))] + (return (list (form$ (list (record$ (list [(record$ (list [(tag$ ["library/lux" "wrap"]) g!wrap] [(tag$ ["library/lux" "bind"]) g!bind])) + body'])) + monad))))) + + _ + (fail "Wrong syntax for do")} + tokens)) + +(def:''' (monad\map m f xs) + #Nil + ## (All [m a b] + ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) + (All [m a b] + (-> ($' Monad m) + (-> a ($' m b)) + ($' List a) + ($' m ($' List b)))) + (let' [{#wrap wrap #bind _} m] + ({#Nil + (wrap #Nil) + + (#Cons x xs') + (do m + [y (f x) + ys (monad\map m f xs')] + (wrap (#Cons y ys)))} + xs))) + +(def:''' (monad\fold m f y xs) + #Nil + ## (All [m a b] + ## (-> (Monad m) (-> a b (m b)) b (List a) (m b))) + (All [m a b] + (-> ($' Monad m) + (-> a b ($' m b)) + b + ($' List a) + ($' m b))) + (let' [{#wrap wrap #bind _} m] + ({#Nil + (wrap y) + + (#Cons x xs') + (do m + [y' (f x y)] + (monad\fold m f y' xs'))} + xs))) + +(macro:' #export (if tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "Picks which expression to evaluate based on a bit test value." __paragraph + "(if #1 ''Oh, yeah!'' ''Aw hell naw!'')" __paragraph + "=> ''Oh, yeah!''"))]) + ({(#Cons test (#Cons then (#Cons else #Nil))) + (return (list (form$ (list (record$ (list [(bit$ #1) then] + [(bit$ #0) else])) + test)))) + + _ + (fail "Wrong syntax for if")} + tokens)) + +(def:''' (get k plist) + #Nil + (All [a] + (-> Text ($' List (& Text a)) ($' Maybe a))) + ({(#Cons [[k' v] plist']) + (if (text\= k k') + (#Some v) + (get k plist')) + + #Nil + #None} + plist)) + +(def:''' (put k v dict) + #Nil + (All [a] + (-> Text a ($' List (& Text a)) ($' List (& Text a)))) + ({#Nil + (list [k v]) + + (#Cons [[k' v'] dict']) + (if (text\= k k') + (#Cons [[k' v] dict']) + (#Cons [[k' v'] (put k v dict')]))} + dict)) + +(def:''' (text\compose x y) + #Nil + (-> Text Text Text) + ("lux text concat" x y)) + +(def:''' (name\encode full_name) + #Nil + (-> Name Text) + (let' [[module name] full_name] + ({"" name + _ ($_ text\compose module "." name)} + module))) + +(def:''' (get_meta tag def_meta) + #Nil + (-> Name Code ($' Maybe Code)) + (let' [[prefix name] tag] + ({[_ (#Record def_meta)] + ({(#Cons [key value] def_meta') + ({[_ (#Tag [prefix' name'])] + ({[#1 #1] + (#Some value) + + _ + (get_meta tag (record$ def_meta'))} + [(text\= prefix prefix') + (text\= name name')]) + + _ + (get_meta tag (record$ def_meta'))} + key) + + #Nil + #None} + def_meta) + + _ + #None} + def_meta))) + +(def:''' (resolve_global_identifier full_name state) + #Nil + (-> Name ($' Meta Name)) + (let' [[module name] full_name + {#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} state] + ({(#Some {#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _}) + ({(#Some constant) + ({(#Left real_name) + (#Right [state real_name]) + + (#Right [exported? def_type def_meta def_value]) + (#Right [state full_name])} + constant) + + #None + (#Left ($_ text\compose "Unknown definition: " (name\encode full_name)))} + (get name definitions)) + + #None + (#Left ($_ text\compose "Unknown module: " module " @ " (name\encode full_name)))} + (get module modules)))) + +(def:''' (as_code_list expression) + #Nil + (-> Code Code) + (let' [type (form$ (list (tag$ ["library/lux" "Apply"]) + (identifier$ ["library/lux" "Code"]) + (identifier$ ["library/lux" "List"])))] + (form$ (list (text$ "lux type check") type expression)))) + +(def:''' (splice replace? untemplate elems) + #Nil + (-> Bit (-> Code ($' Meta Code)) ($' List Code) ($' Meta Code)) + ({#1 + ({#Nil + (return (tag$ ["library/lux" "Nil"])) + + (#Cons lastI inits) + (do meta_monad + [lastO ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] + (wrap (as_code_list spliced)) + + _ + (do meta_monad + [lastO (untemplate lastI)] + (wrap (as_code_list (form$ (list (tag$ ["library/lux" "Cons"]) + (tuple$ (list lastO (tag$ ["library/lux" "Nil"]))))))))} + lastI)] + (monad\fold meta_monad + (function' [leftI rightO] + ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] + (let' [g!in-module (form$ (list (text$ "lux in-module") + (text$ "library/lux") + (identifier$ ["library/lux" "list\compose"])))] + (wrap (form$ (list g!in-module (as_code_list spliced) rightO)))) + + _ + (do meta_monad + [leftO (untemplate leftI)] + (wrap (form$ (list (tag$ ["library/lux" "Cons"]) (tuple$ (list leftO rightO))))))} + leftI)) + lastO + inits))} + (list\reverse elems)) + #0 + (do meta_monad + [=elems (monad\map meta_monad untemplate elems)] + (wrap (untemplate_list =elems)))} + replace?)) + +(def:''' (untemplate_text value) + #Nil + (-> Text Code) + (wrap_meta (form$ (list (tag$ ["library/lux" "Text"]) (text$ value))))) + +(def:''' (untemplate replace? subst token) + #Nil + (-> Bit Text Code ($' Meta Code)) + ({[_ [_ (#Bit value)]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Bit"]) (bit$ value))))) + + [_ [_ (#Nat value)]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Nat"]) (nat$ value))))) + + [_ [_ (#Int value)]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Int"]) (int$ value))))) + + [_ [_ (#Rev value)]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Rev"]) (rev$ value))))) + + [_ [_ (#Frac value)]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Frac"]) (frac$ value))))) + + [_ [_ (#Text value)]] + (return (untemplate_text value)) + + [#0 [_ (#Tag [module name])]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Tag"]) (tuple$ (list (text$ module) (text$ name))))))) + + [#1 [_ (#Tag [module name])]] + (let' [module' ({"" + subst + + _ + module} + module)] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Tag"]) (tuple$ (list (text$ module') (text$ name)))))))) + + [#1 [_ (#Identifier [module name])]] + (do meta_monad + [real_name ({"" + (if (text\= "" subst) + (wrap [module name]) + (resolve_global_identifier [subst name])) + + _ + (wrap [module name])} + module) + #let [[module name] real_name]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Identifier"]) (tuple$ (list (text$ module) (text$ name)))))))) + + [#0 [_ (#Identifier [module name])]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Identifier"]) (tuple$ (list (text$ module) (text$ name))))))) + + [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))]] + (return (form$ (list (text$ "lux type check") + (identifier$ ["library/lux" "Code"]) + unquoted))) + + [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~!"])] (#Cons [dependent #Nil])]))]] + (do meta_monad + [independent (untemplate replace? subst dependent)] + (wrap (wrap_meta (form$ (list (tag$ ["library/lux" "Form"]) + (untemplate_list (list (untemplate_text "lux in-module") + (untemplate_text subst) + independent))))))) + + [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~'"])] (#Cons [keep_quoted #Nil])]))]] + (untemplate #0 subst keep_quoted) + + [_ [meta (#Form elems)]] + (do meta_monad + [output (splice replace? (untemplate replace? subst) elems) + #let [[_ output'] (wrap_meta (form$ (list (tag$ ["library/lux" "Form"]) output)))]] + (wrap [meta output'])) + + [_ [meta (#Tuple elems)]] + (do meta_monad + [output (splice replace? (untemplate replace? subst) elems) + #let [[_ output'] (wrap_meta (form$ (list (tag$ ["library/lux" "Tuple"]) output)))]] + (wrap [meta output'])) + + [_ [_ (#Record fields)]] + (do meta_monad + [=fields (monad\map meta_monad + ("lux type check" (-> (& Code Code) ($' Meta Code)) + (function' [kv] + (let' [[k v] kv] + (do meta_monad + [=k (untemplate replace? subst k) + =v (untemplate replace? subst v)] + (wrap (tuple$ (list =k =v))))))) + fields)] + (wrap (wrap_meta (form$ (list (tag$ ["library/lux" "Record"]) (untemplate_list =fields))))))} + [replace? token])) + +(macro:' #export (primitive tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Macro to treat define new primitive types." __paragraph + "(primitive ''java.lang.Object'')" __paragraph + "(primitive ''java.util.List'' [(primitive ''java.lang.Long'')])"))]) + ({(#Cons [_ (#Text class_name)] #Nil) + (return (list (form$ (list (tag$ ["library/lux" "Primitive"]) (text$ class_name) (tag$ ["library/lux" "Nil"]))))) + + (#Cons [_ (#Text class_name)] (#Cons [_ (#Tuple params)] #Nil)) + (return (list (form$ (list (tag$ ["library/lux" "Primitive"]) (text$ class_name) (untemplate_list params))))) + + _ + (fail "Wrong syntax for primitive")} + tokens)) + +(def:'' (current_module_name state) + #Nil + ($' Meta Text) + ({{#info info #source source #current_module current_module #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} + ({(#Some module_name) + (#Right [state module_name]) + + _ + (#Left "Cannot get the module name without a module!")} + current_module)} + state)) + +(macro:' #export (` tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Hygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph + "## All unprefixed macros will receive their parent module's prefix if imported; otherwise will receive the prefix of the module on which the quasi-quote is being used." __paragraph + "(` (def: (~ name) (function ((~' _) (~+ args)) (~ body))))"))]) + ({(#Cons template #Nil) + (do meta_monad + [current_module current_module_name + =template (untemplate #1 current_module template)] + (wrap (list (form$ (list (text$ "lux type check") + (identifier$ ["library/lux" "Code"]) + =template))))) + + _ + (fail "Wrong syntax for `")} + tokens)) + +(macro:' #export (`' tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph + "(`' (def: (~ name) (function (_ (~+ args)) (~ body))))"))]) + ({(#Cons template #Nil) + (do meta_monad + [=template (untemplate #1 "" template)] + (wrap (list (form$ (list (text$ "lux type check") (identifier$ ["library/lux" "Code"]) =template))))) + + _ + (fail "Wrong syntax for `")} + tokens)) + +(macro:' #export (' tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Quotation as a macro." __paragraph + "(' YOLO)"))]) + ({(#Cons template #Nil) + (do meta_monad + [=template (untemplate #0 "" template)] + (wrap (list (form$ (list (text$ "lux type check") (identifier$ ["library/lux" "Code"]) =template))))) + + _ + (fail "Wrong syntax for '")} + tokens)) + +(macro:' #export (|> tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Piping macro." __paragraph + "(|> elems (list\map int\encode) (interpose '' '') (fold text\compose ''''))" __paragraph + "## =>" __paragraph + "(fold text\compose '''' (interpose '' '' (list\map int\encode elems)))"))]) + ({(#Cons [init apps]) + (return (list (list\fold ("lux type check" (-> Code Code Code) + (function' [app acc] + ({[_ (#Tuple parts)] + (tuple$ (list\compose parts (list acc))) + + [_ (#Form parts)] + (form$ (list\compose parts (list acc))) + + _ + (` ((~ app) (~ acc)))} + app))) + init + apps))) + + _ + (fail "Wrong syntax for |>")} + tokens)) + +(macro:' #export (<| tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Reverse piping macro." __paragraph + "(<| (fold text\compose '''') (interpose '' '') (list\map int\encode) elems)" __paragraph + "## =>" __paragraph + "(fold text\compose '''' (interpose '' '' (list\map int\encode elems)))"))]) + ({(#Cons [init apps]) + (return (list (list\fold ("lux type check" (-> Code Code Code) + (function' [app acc] + ({[_ (#Tuple parts)] + (tuple$ (list\compose parts (list acc))) + + [_ (#Form parts)] + (form$ (list\compose parts (list acc))) + + _ + (` ((~ app) (~ acc)))} + app))) + init + apps))) + + _ + (fail "Wrong syntax for <|")} + (list\reverse tokens))) + +(def:''' (compose f g) + (list [(tag$ ["library/lux" "doc"]) + (text$ "Function composition.")]) + (All [a b c] + (-> (-> b c) (-> a b) (-> a c))) + (function' [x] (f (g x)))) + +(def:''' (get_name x) + #Nil + (-> Code ($' Maybe Name)) + ({[_ (#Identifier sname)] + (#Some sname) + + _ + #None} + x)) + +(def:''' (get_tag x) + #Nil + (-> Code ($' Maybe Name)) + ({[_ (#Tag sname)] + (#Some sname) + + _ + #None} + x)) + +(def:''' (get_short x) + #Nil + (-> Code ($' Maybe Text)) + ({[_ (#Identifier "" sname)] + (#Some sname) + + _ + #None} + x)) + +(def:''' (tuple->list tuple) + #Nil + (-> Code ($' Maybe ($' List Code))) + ({[_ (#Tuple members)] + (#Some members) + + _ + #None} + tuple)) + +(def:''' (apply_template env template) + #Nil + (-> RepEnv Code Code) + ({[_ (#Identifier "" sname)] + ({(#Some subst) + subst + + _ + template} + (get_rep sname env)) + + [meta (#Tuple elems)] + [meta (#Tuple (list\map (apply_template env) elems))] + + [meta (#Form elems)] + [meta (#Form (list\map (apply_template env) elems))] + + [meta (#Record members)] + [meta (#Record (list\map ("lux type check" (-> (& Code Code) (& Code Code)) + (function' [kv] + (let' [[slot value] kv] + [(apply_template env slot) (apply_template env value)]))) + members))] + + _ + template} + template)) + +(def:''' (every? p xs) + #Nil + (All [a] + (-> (-> a Bit) ($' List a) Bit)) + (list\fold (function' [_2 _1] (if _1 (p _2) #0)) #1 xs)) + +(def:''' (high_bits value) + (list) + (-> ($' I64 Any) I64) + ("lux i64 right-shift" 32 value)) + +(def:''' low_mask + (list) + I64 + (|> 1 ("lux i64 left-shift" 32) ("lux i64 -" 1))) + +(def:''' (low_bits value) + (list) + (-> ($' I64 Any) I64) + ("lux i64 and" low_mask value)) + +(def:''' (n/< reference sample) + (list) + (-> Nat Nat Bit) + (let' [referenceH (high_bits reference) + sampleH (high_bits sample)] + (if ("lux i64 <" referenceH sampleH) + #1 + (if ("lux i64 =" referenceH sampleH) + ("lux i64 <" + (low_bits reference) + (low_bits sample)) + #0)))) + +(def:''' (n/<= reference sample) + (list) + (-> Nat Nat Bit) + (if (n/< reference sample) + #1 + ("lux i64 =" reference sample))) + +(def:''' (list\join xs) + #Nil + (All [a] + (-> ($' List ($' List a)) ($' List a))) + (list\fold list\compose #Nil (list\reverse xs))) + +(macro:' #export (template tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary." __paragraph + "(template [<name> <diff>]" ..\n + " " "[(def: #export <name> (-> Int Int) (+ <diff>))]" __paragraph + " " "[inc +1]" ..\n + " " "[dec -1]"))]) + ({(#Cons [[_ (#Tuple bindings)] (#Cons [[_ (#Tuple templates)] data])]) + ({[(#Some bindings') (#Some data')] + (let' [apply ("lux type check" (-> RepEnv ($' List Code)) + (function' [env] (list\map (apply_template env) templates))) + num_bindings (list\size bindings')] + (if (every? (function' [size] ("lux i64 =" num_bindings size)) + (list\map list\size data')) + (|> data' + (list\map (compose apply (make_env bindings'))) + list\join + return) + (fail "Irregular arguments tuples for template."))) + + _ + (fail "Wrong syntax for template")} + [(monad\map maybe_monad get_short bindings) + (monad\map maybe_monad tuple->list data)]) + + _ + (fail "Wrong syntax for template")} + tokens)) + +(def:''' (n// param subject) + (list) + (-> Nat Nat Nat) + (if ("lux i64 <" +0 ("lux type as" Int param)) + (if (n/< param subject) + 0 + 1) + (let' [quotient (|> subject + ("lux i64 right-shift" 1) + ("lux i64 /" ("lux type as" Int param)) + ("lux i64 left-shift" 1)) + flat ("lux i64 *" + ("lux type as" Int param) + ("lux type as" Int quotient)) + remainder ("lux i64 -" flat subject)] + (if (n/< param remainder) + quotient + ("lux i64 +" 1 quotient))))) + +(def:''' (n/% param subject) + (list) + (-> Nat Nat Nat) + (let' [flat ("lux i64 *" + ("lux type as" Int param) + ("lux type as" Int (n// param subject)))] + ("lux i64 -" flat subject))) + +(def:''' (n/min left right) + (list) + (-> Nat Nat Nat) + (if (n/< right left) + left + right)) + +(def:''' (bit\encode x) + #Nil + (-> Bit Text) + (if x "#1" "#0")) + +(def:''' (digit::format digit) + #Nil + (-> Nat Text) + ({0 "0" + 1 "1" 2 "2" 3 "3" + 4 "4" 5 "5" 6 "6" + 7 "7" 8 "8" 9 "9" + _ ("lux io error" "@digit::format Undefined behavior.")} + digit)) + +(def:''' (nat\encode value) + #Nil + (-> Nat Text) + ({0 + "0" + + _ + (let' [loop ("lux type check" (-> Nat Text Text) + (function' recur [input output] + (if ("lux i64 =" 0 input) + output + (recur (n// 10 input) + (text\compose (|> input (n/% 10) digit::format) + output)))))] + (loop value ""))} + value)) + +(def:''' (int\abs value) + #Nil + (-> Int Int) + (if ("lux i64 <" +0 value) + ("lux i64 *" -1 value) + value)) + +(def:''' (int\encode value) + #Nil + (-> Int Text) + (if ("lux i64 =" +0 value) + "+0" + (let' [sign (if ("lux i64 <" value +0) + "+" + "-")] + (("lux type check" (-> Int Text Text) + (function' recur [input output] + (if ("lux i64 =" +0 input) + (text\compose sign output) + (recur ("lux i64 /" +10 input) + (text\compose (|> input ("lux i64 %" +10) ("lux type as" Nat) digit::format) + output))))) + (|> value ("lux i64 /" +10) int\abs) + (|> value ("lux i64 %" +10) int\abs ("lux type as" Nat) digit::format))))) + +(def:''' (frac\encode x) + #Nil + (-> Frac Text) + ("lux f64 encode" x)) + +(def:''' (multiple? div n) + #Nil + (-> Nat Nat Bit) + (|> n (n/% div) ("lux i64 =" 0))) + +(def:''' #export (not x) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Bit negation." __paragraph + "(not #1) => #0" __paragraph + "(not #0) => #1"))]) + (-> Bit Bit) + (if x #0 #1)) + +(def:''' (macro_type? type) + (list) + (-> Type Bit) + ({(#Named ["library/lux" "Macro"] (#Primitive "#Macro" #Nil)) + #1 + + _ + #0} + type)) + +(def:''' (find_macro' modules current_module module name) + #Nil + (-> ($' List (& Text Module)) + Text Text Text + ($' Maybe Macro)) + (do maybe_monad + [$module (get module modules) + gdef (let' [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags #types types #module_annotations _ #module_state _} ("lux type check" Module $module)] + (get name bindings))] + ({(#Left [r_module r_name]) + (find_macro' modules current_module r_module r_name) + + (#Right [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)} + ("lux type check" Global gdef)))) + +(def:''' (normalize name) + #Nil + (-> Name ($' Meta Name)) + ({["" name] + (do meta_monad + [module_name current_module_name] + (wrap [module_name name])) + + _ + (return name)} + name)) + +(def:''' (find_macro full_name) + #Nil + (-> Name ($' Meta ($' Maybe Macro))) + (do meta_monad + [current_module current_module_name] + (let' [[module name] full_name] + (function' [state] + ({{#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected + #location location #extensions extensions + #scope_type_vars scope_type_vars} + (#Right state (find_macro' modules current_module module name))} + state))))) + +(def:''' (macro? name) + #Nil + (-> Name ($' Meta Bit)) + (do meta_monad + [name (normalize name) + output (find_macro name)] + (wrap ({(#Some _) #1 + #None #0} + output)))) + +(def:''' (interpose sep xs) + #Nil + (All [a] + (-> a ($' List a) ($' List a))) + ({#Nil + xs + + (#Cons [x #Nil]) + xs + + (#Cons [x xs']) + (list& x sep (interpose sep xs'))} + xs)) + +(def:''' (macro_expand_once token) + #Nil + (-> Code ($' Meta ($' List Code))) + ({[_ (#Form (#Cons [_ (#Identifier macro_name)] args))] + (do meta_monad + [macro_name' (normalize macro_name) + ?macro (find_macro macro_name')] + ({(#Some macro) + (("lux type as" Macro' macro) args) + + #None + (return (list token))} + ?macro)) + + _ + (return (list token))} + token)) + +(def:''' (macro_expand token) + #Nil + (-> Code ($' Meta ($' List Code))) + ({[_ (#Form (#Cons [_ (#Identifier macro_name)] args))] + (do meta_monad + [macro_name' (normalize macro_name) + ?macro (find_macro macro_name')] + ({(#Some macro) + (do meta_monad + [expansion (("lux type as" Macro' macro) args) + expansion' (monad\map meta_monad macro_expand expansion)] + (wrap (list\join expansion'))) + + #None + (return (list token))} + ?macro)) + + _ + (return (list token))} + token)) + +(def:''' (macro_expand_all syntax) + #Nil + (-> Code ($' Meta ($' List Code))) + ({[_ (#Form (#Cons [_ (#Identifier macro_name)] args))] + (do meta_monad + [macro_name' (normalize macro_name) + ?macro (find_macro macro_name')] + ({(#Some macro) + (do meta_monad + [expansion (("lux type as" Macro' macro) args) + expansion' (monad\map meta_monad macro_expand_all expansion)] + (wrap (list\join expansion'))) + + #None + (do meta_monad + [args' (monad\map meta_monad macro_expand_all args)] + (wrap (list (form$ (#Cons (identifier$ macro_name) (list\join args'))))))} + ?macro)) + + [_ (#Form members)] + (do meta_monad + [members' (monad\map meta_monad macro_expand_all members)] + (wrap (list (form$ (list\join members'))))) + + [_ (#Tuple members)] + (do meta_monad + [members' (monad\map meta_monad macro_expand_all members)] + (wrap (list (tuple$ (list\join members'))))) + + [_ (#Record pairs)] + (do meta_monad + [pairs' (monad\map meta_monad + (function' [kv] + (let' [[key val] kv] + (do meta_monad + [val' (macro_expand_all val)] + ({(#Cons val'' #Nil) + (return [key val'']) + + _ + (fail "The value-part of a KV-pair in a record must macro-expand to a single Code.")} + val')))) + pairs)] + (wrap (list (record$ pairs')))) + + _ + (return (list syntax))} + syntax)) + +(def:''' (walk_type type) + #Nil + (-> Code Code) + ({[_ (#Form (#Cons [_ (#Tag tag)] parts))] + (form$ (#Cons [(tag$ tag) (list\map walk_type parts)])) + + [_ (#Tuple members)] + (` (& (~+ (list\map walk_type members)))) + + [_ (#Form (#Cons [_ (#Text "lux in-module")] + (#Cons [_ (#Text module)] + (#Cons type' + #Nil))))] + (` ("lux in-module" (~ (text$ module)) (~ (walk_type type')))) + + [_ (#Form (#Cons [_ (#Identifier ["" ":~"])] (#Cons expression #Nil)))] + expression + + [_ (#Form (#Cons type_fn args))] + (list\fold ("lux type check" (-> Code Code Code) + (function' [arg type_fn] (` (#.Apply (~ arg) (~ type_fn))))) + (walk_type type_fn) + (list\map walk_type args)) + + _ + type} + type)) + +(macro:' #export (type tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Takes a type expression and returns it's representation as data-structure." __paragraph + "(type (All [a] (Maybe (List a))))"))]) + ({(#Cons type #Nil) + (do meta_monad + [type+ (macro_expand_all type)] + ({(#Cons type' #Nil) + (wrap (list (walk_type type'))) + + _ + (fail "The expansion of the type-syntax had to yield a single element.")} + type+)) + + _ + (fail "Wrong syntax for type")} + tokens)) + +(macro:' #export (: tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## The type-annotation macro." __paragraph + "(: (List Int) (list +1 +2 +3))"))]) + ({(#Cons type (#Cons value #Nil)) + (return (list (` ("lux type check" (type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :")} + tokens)) + +(macro:' #export (:as tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## The type-coercion macro." __paragraph + "(:as Dinosaur (list +1 +2 +3))"))]) + ({(#Cons type (#Cons value #Nil)) + (return (list (` ("lux type as" (type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :as")} + tokens)) + +(def:''' (empty? xs) + #Nil + (All [a] (-> ($' List a) Bit)) + ({#Nil #1 + _ #0} + xs)) + +(template [<name> <type> <value>] + [(def:''' (<name> xy) + #Nil + (All [a b] (-> (& a b) <type>)) + (let' [[x y] xy] <value>))] + + [first a x] + [second b y]) + +(def:''' (unfold_type_def type_codes) + #Nil + (-> ($' List Code) ($' Meta (& Code ($' Maybe ($' List Text))))) + ({(#Cons [_ (#Record pairs)] #Nil) + (do meta_monad + [members (monad\map meta_monad + (: (-> [Code Code] (Meta [Text Code])) + (function' [pair] + ({[[_ (#Tag "" member_name)] member_type] + (return [member_name member_type]) + + _ + (fail "Wrong syntax for variant case.")} + pair))) + pairs)] + (return [(` (& (~+ (list\map second members)))) + (#Some (list\map first members))])) + + (#Cons type #Nil) + ({[_ (#Tag "" member_name)] + (return [(` .Any) (#Some (list member_name))]) + + [_ (#Form (#Cons [_ (#Tag "" member_name)] member_types))] + (return [(` (& (~+ member_types))) (#Some (list member_name))]) + + _ + (return [type #None])} + type) + + (#Cons case cases) + (do meta_monad + [members (monad\map meta_monad + (: (-> Code (Meta [Text Code])) + (function' [case] + ({[_ (#Tag "" member_name)] + (return [member_name (` .Any)]) + + [_ (#Form (#Cons [_ (#Tag "" member_name)] (#Cons member_type #Nil)))] + (return [member_name member_type]) + + [_ (#Form (#Cons [_ (#Tag "" member_name)] member_types))] + (return [member_name (` (& (~+ member_types)))]) + + _ + (fail "Wrong syntax for variant case.")} + case))) + (list& case cases))] + (return [(` (| (~+ (list\map second members)))) + (#Some (list\map first members))])) + + _ + (fail "Improper type-definition syntax")} + type_codes)) + +(def:''' (gensym prefix state) + #Nil + (-> Text ($' Meta Code)) + ({{#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected + #location location #extensions extensions + #scope_type_vars scope_type_vars} + (#Right {#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed ("lux i64 +" 1 seed) #expected expected + #location location #extensions extensions + #scope_type_vars scope_type_vars} + (local_identifier$ ($_ text\compose "__gensym__" prefix (nat\encode seed))))} + state)) + +(macro:' #export (Rec tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Parameter-less recursive types." __paragraph + "## A name has to be given to the whole type, to use it within its body." __paragraph + "(Rec Self [Int (List Self)])"))]) + ({(#Cons [_ (#Identifier "" name)] (#Cons body #Nil)) + (let' [body' (replace_syntax (list [name (` (#.Apply (~ (make_parameter 1)) (~ (make_parameter 0))))]) + (update_parameters body))] + (return (list (` (#.Apply .Nothing (#.UnivQ #.Nil (~ body'))))))) + + _ + (fail "Wrong syntax for Rec")} + tokens)) + +(macro:' #export (exec tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Sequential execution of expressions (great for side-effects)." __paragraph + "(exec" ..\n + " " "(log! ''#1'')" ..\n + " " "(log! ''#2'')" ..\n + " " "(log! ''#3'')" ..\n + "''YOLO'')"))]) + ({(#Cons value actions) + (let' [dummy (local_identifier$ "")] + (return (list (list\fold ("lux type check" (-> Code Code Code) + (function' [pre post] (` ({(~ dummy) (~ post)} + (~ pre))))) + value + actions)))) + + _ + (fail "Wrong syntax for exec")} + (list\reverse tokens))) + +(macro:' (def:' tokens) + (let' [[export? tokens'] ({(#Cons [_ (#Tag ["" "export"])] tokens') + [#1 tokens'] + + _ + [#0 tokens]} + tokens) + parts (: (Maybe [Code (List Code) (Maybe Code) Code]) + ({(#Cons [_ (#Form (#Cons name args))] (#Cons type (#Cons body #Nil))) + (#Some name args (#Some type) body) + + (#Cons name (#Cons type (#Cons body #Nil))) + (#Some name #Nil (#Some type) body) + + (#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil)) + (#Some name args #None body) + + (#Cons name (#Cons body #Nil)) + (#Some name #Nil #None body) + + _ + #None} + tokens'))] + ({(#Some name args ?type body) + (let' [body' ({#Nil + body + + _ + (` (function' (~ name) [(~+ args)] (~ body)))} + args) + body'' ({(#Some type) + (` (: (~ type) (~ body'))) + + #None + body'} + ?type)] + (return (list (` ("lux def" (~ name) + (~ body'') + [(~ location_code) + (#.Record #.Nil)] + (~ (bit$ export?))))))) + + #None + (fail "Wrong syntax for def'")} + parts))) + +(def:' (rejoin_pair pair) + (-> [Code Code] (List Code)) + (let' [[left right] pair] + (list left right))) + +(def:' (text\encode original) + (-> Text Text) + ($_ text\compose ..double_quote original ..double_quote)) + +(def:' (code\encode code) + (-> Code Text) + ({[_ (#Bit value)] + (bit\encode value) + + [_ (#Nat value)] + (nat\encode value) + + [_ (#Int value)] + (int\encode value) + + [_ (#Rev value)] + ("lux io error" "@code\encode Undefined behavior.") + + [_ (#Frac value)] + (frac\encode value) + + [_ (#Text value)] + (text\encode value) + + [_ (#Identifier [prefix name])] + (if (text\= "" prefix) + name + ($_ text\compose prefix "." name)) + + [_ (#Tag [prefix name])] + (if (text\= "" prefix) + ($_ text\compose "#" name) + ($_ text\compose "#" prefix "." name)) + + [_ (#Form xs)] + ($_ text\compose "(" (|> xs + (list\map code\encode) + (interpose " ") + list\reverse + (list\fold text\compose "")) ")") + + [_ (#Tuple xs)] + ($_ text\compose "[" (|> xs + (list\map code\encode) + (interpose " ") + list\reverse + (list\fold text\compose "")) "]") + + [_ (#Record kvs)] + ($_ text\compose "{" (|> kvs + (list\map (function' [kv] ({[k v] ($_ text\compose (code\encode k) " " (code\encode v))} + kv))) + (interpose " ") + list\reverse + (list\fold text\compose "")) "}")} + code)) + +(def:' (expander branches) + (-> (List Code) (Meta (List Code))) + ({(#Cons [_ (#Form (#Cons [_ (#Identifier macro_name)] macro_args))] + (#Cons body + branches')) + (do meta_monad + [??? (macro? macro_name)] + (if ??? + (do meta_monad + [init_expansion (macro_expand_once (form$ (list& (identifier$ macro_name) (form$ macro_args) body branches')))] + (expander init_expansion)) + (do meta_monad + [sub_expansion (expander branches')] + (wrap (list& (form$ (list& (identifier$ macro_name) macro_args)) + body + sub_expansion))))) + + (#Cons pattern (#Cons body branches')) + (do meta_monad + [sub_expansion (expander branches')] + (wrap (list& pattern body sub_expansion))) + + #Nil + (do meta_monad [] (wrap (list))) + + _ + (fail ($_ text\compose "'lux.case' expects an even number of tokens: " (|> branches + (list\map code\encode) + (interpose " ") + list\reverse + (list\fold text\compose ""))))} + branches)) + +(macro:' #export (case tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## The pattern-matching macro." ..\n + "## Allows the usage of macros within the patterns to provide custom syntax." ..\n + "(case (: (List Int) (list +1 +2 +3))" ..\n + " " "(#Cons x (#Cons y (#Cons z #Nil)))" ..\n + " " "(#Some ($_ * x y z))" __paragraph + " " "_" ..\n + " " "#None)"))]) + ({(#Cons value branches) + (do meta_monad + [expansion (expander branches)] + (wrap (list (` ((~ (record$ (as_pairs expansion))) (~ value)))))) + + _ + (fail "Wrong syntax for case")} + tokens)) + +(macro:' #export (^ tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Macro-expanding patterns." ..\n + "## It's a special macro meant to be used with 'case'." ..\n + "(case (: (List Int) (list +1 +2 +3))" ..\n + " (^ (list x y z))" ..\n + " (#Some ($_ * x y z))" + __paragraph + " _" ..\n + " #None)"))]) + (case tokens + (#Cons [_ (#Form (#Cons pattern #Nil))] (#Cons body branches)) + (do meta_monad + [pattern+ (macro_expand_all pattern)] + (case pattern+ + (#Cons pattern' #Nil) + (wrap (list& pattern' body branches)) + + _ + (fail "^ can only expand to 1 pattern."))) + + _ + (fail "Wrong syntax for ^ macro"))) + +(macro:' #export (^or tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Or-patterns." ..\n + "## It's a special macro meant to be used with 'case'." ..\n + "(type: Weekday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday #Sunday)" + __paragraph + "(def: (weekend? day)" ..\n + " (-> Weekday Bit)" ..\n + " (case day" ..\n + " (^or #Saturday #Sunday)" ..\n + " #1" + __paragraph + " _" ..\n + " #0))"))]) + (case tokens + (^ (list& [_ (#Form patterns)] body branches)) + (case patterns + #Nil + (fail "^or cannot have 0 patterns") + + _ + (let' [pairs (|> patterns + (list\map (function' [pattern] (list pattern body))) + (list\join))] + (return (list\compose pairs branches)))) + _ + (fail "Wrong syntax for ^or"))) + +(def:' (identifier? code) + (-> Code Bit) + (case code + [_ (#Identifier _)] + #1 + + _ + #0)) + +(macro:' #export (let tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Creates local bindings." ..\n + "## Can (optionally) use pattern-matching macros when binding." ..\n + "(let [x (foo bar)" ..\n + " y (baz quux)]" ..\n + " (op x y))"))]) + (case tokens + (^ (list [_ (#Tuple bindings)] body)) + (if (multiple? 2 (list\size bindings)) + (|> bindings as_pairs list\reverse + (list\fold (: (-> [Code Code] Code Code) + (function' [lr body'] + (let' [[l r] lr] + (if (identifier? l) + (` ({(~ l) (~ body')} (~ r))) + (` (case (~ r) (~ l) (~ body'))))))) + body) + list + return) + (fail "let requires an even number of parts")) + + _ + (fail "Wrong syntax for let"))) + +(macro:' #export (function tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Syntax for creating functions." ..\n + "## Allows for giving the function itself a name, for the sake of recursion." ..\n + "(: (All [a b] (-> a b a))" ..\n + " (function (_ x y) x))" + __paragraph + "(: (All [a b] (-> a b a))" ..\n + " (function (const x y) x))"))]) + (case (: (Maybe [Text Code (List Code) Code]) + (case tokens + (^ (list [_ (#Form (list& [_ (#Identifier ["" name])] head tail))] body)) + (#Some name head tail body) + + _ + #None)) + (#Some g!name head tail body) + (let [g!blank (local_identifier$ "") + nest (: (-> Code (-> Code Code Code)) + (function' [g!name] + (function' [arg body'] + (if (identifier? arg) + (` ([(~ g!name) (~ arg)] (~ body'))) + (` ([(~ g!name) (~ g!blank)] + (.case (~ g!blank) (~ arg) (~ body'))))))))] + (return (list (nest (..local_identifier$ g!name) head + (list\fold (nest g!blank) body (list\reverse tail)))))) + + #None + (fail "Wrong syntax for function"))) + +(def:' (process_def_meta_value code) + (-> Code Code) + (case code + [_ (#Bit value)] + (meta_code ["library/lux" "Bit"] (bit$ value)) + + [_ (#Nat value)] + (meta_code ["library/lux" "Nat"] (nat$ value)) + + [_ (#Int value)] + (meta_code ["library/lux" "Int"] (int$ value)) + + [_ (#Rev value)] + (meta_code ["library/lux" "Rev"] (rev$ value)) + + [_ (#Frac value)] + (meta_code ["library/lux" "Frac"] (frac$ value)) + + [_ (#Text value)] + (meta_code ["library/lux" "Text"] (text$ value)) + + [_ (#Tag [prefix name])] + (meta_code ["library/lux" "Tag"] (` [(~ (text$ prefix)) (~ (text$ name))])) + + (^or [_ (#Form _)] [_ (#Identifier _)]) + code + + [_ (#Tuple xs)] + (|> xs + (list\map process_def_meta_value) + untemplate_list + (meta_code ["library/lux" "Tuple"])) + + [_ (#Record kvs)] + (|> kvs + (list\map (: (-> [Code Code] Code) + (function (_ [k v]) + (` [(~ (process_def_meta_value k)) + (~ (process_def_meta_value v))])))) + untemplate_list + (meta_code ["library/lux" "Record"])) + )) + +(def:' (process_def_meta kvs) + (-> (List [Code Code]) Code) + (untemplate_list (list\map (: (-> [Code Code] Code) + (function (_ [k v]) + (` [(~ (process_def_meta_value k)) + (~ (process_def_meta_value v))]))) + kvs))) + +(def:' (with_func_args args meta) + (-> (List Code) Code Code) + (case args + #Nil + meta + + _ + (` (#.Cons [[(~ location_code) (#.Tag ["library/lux" "func-args"])] + [(~ location_code) (#.Tuple (.list (~+ (list\map (function (_ arg) + (` [(~ location_code) (#.Text (~ (text$ (code\encode arg))))])) + args))))]] + (~ meta))))) + +(def:' (with_type_args args) + (-> (List Code) Code) + (` {#.type-args [(~+ (list\map (function (_ arg) (text$ (code\encode arg))) + args))]})) + +(def:' (export^ tokens) + (-> (List Code) [Bit (List Code)]) + (case tokens + (#Cons [_ (#Tag [_ "export"])] tokens') + [#1 tokens'] + + _ + [#0 tokens])) + +(def:' (export ?) + (-> Bit (List Code)) + (if ? + (list (' #export)) + (list))) + +(macro:' #export (def: tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Defines global constants/functions." ..\n + "(def: (rejoin_pair pair)" ..\n + " (-> [Code Code] (List Code))" ..\n + " (let [[left right] pair]" ..\n + " (list left right)))" + __paragraph + "(def: branching_exponent" ..\n + " Int" ..\n + " +5)"))]) + (let [[exported? tokens'] (export^ tokens) + parts (: (Maybe [Code (List Code) (Maybe Code) Code (List [Code Code])]) + (case tokens' + (^ (list [_ (#Form (#Cons name args))] [_ (#Record meta_kvs)] type body)) + (#Some [name args (#Some type) body meta_kvs]) + + (^ (list name [_ (#Record meta_kvs)] type body)) + (#Some [name #Nil (#Some type) body meta_kvs]) + + (^ (list [_ (#Form (#Cons name args))] [_ (#Record meta_kvs)] body)) + (#Some [name args #None body meta_kvs]) + + (^ (list name [_ (#Record meta_kvs)] body)) + (#Some [name #Nil #None body meta_kvs]) + + (^ (list [_ (#Form (#Cons name args))] type body)) + (#Some [name args (#Some type) body #Nil]) + + (^ (list name type body)) + (#Some [name #Nil (#Some type) body #Nil]) + + (^ (list [_ (#Form (#Cons name args))] body)) + (#Some [name args #None body #Nil]) + + (^ (list name body)) + (#Some [name #Nil #None body #Nil]) + + _ + #None))] + (case parts + (#Some name args ?type body meta) + (let [body (case args + #Nil + body + + _ + (` (function ((~ name) (~+ args)) (~ body)))) + body (case ?type + (#Some type) + (` (: (~ type) (~ body))) + + #None + body) + =meta (process_def_meta meta)] + (return (list (` ("lux def" (~ name) + (~ body) + [(~ location_code) + (#.Record (~ (with_func_args args =meta)))] + (~ (bit$ exported?))))))) + + #None + (fail "Wrong syntax for def:")))) + +(def: (meta_code_add addition meta) + (-> [Code Code] Code Code) + (case [addition meta] + [[name value] [location (#Record pairs)]] + [location (#Record (#Cons [name value] pairs))] + + _ + meta)) + +(def: (meta_code_merge addition base) + (-> Code Code Code) + (case addition + [location (#Record pairs)] + (list\fold meta_code_add base pairs) + + _ + base)) + +(macro:' #export (macro: tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Macro-definition macro." ..\n + "(macro: #export (name_of tokens)" ..\n + " (case tokens" ..\n + " (^template [<tag>]" ..\n + " [(^ (list [_ (<tag> [prefix name])]))" ..\n + " (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))])" ..\n + " ([#Identifier] [#Tag])" + __paragraph + " _" ..\n + " (fail ''Wrong syntax for name_of'')))"))]) + (let [[exported? tokens] (export^ tokens) + name+args+meta+body?? (: (Maybe [Name (List Code) (List [Code Code]) Code]) + (case tokens + (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] body)) + (#Some [name args (list) body]) + + (^ (list [_ (#Identifier name)] body)) + (#Some [name #Nil (list) body]) + + (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] [_ (#Record meta_rec_parts)] body)) + (#Some [name args meta_rec_parts body]) + + (^ (list [_ (#Identifier name)] [_ (#Record meta_rec_parts)] body)) + (#Some [name #Nil meta_rec_parts body]) + + _ + #None))] + (case name+args+meta+body?? + (#Some [name args meta body]) + (let [name (identifier$ name) + body (case args + #Nil + body + + _ + (` ("lux macro" + (function ((~ name) (~+ args)) (~ body))))) + =meta (process_def_meta meta)] + (return (list (` ("lux def" (~ name) + (~ body) + [(~ location_code) + (#Record (~ =meta))] + (~ (bit$ exported?))))))) + + #None + (fail "Wrong syntax for macro:")))) + +(macro: #export (interface: tokens) + {#.doc (text$ ($_ "lux text concat" + "## Definition of signatures ala ML." ..\n + "(interface: #export (Ord a)" ..\n + " (: (Equivalence a)" ..\n + " eq)" ..\n + " (: (-> a a Bit)" ..\n + " <)" ..\n + " (: (-> a a Bit)" ..\n + " <=)" ..\n + " (: (-> a a Bit)" ..\n + " >)" ..\n + " (: (-> a a Bit)" ..\n + " >=))"))} + (let [[exported? tokens'] (export^ tokens) + ?parts (: (Maybe [Name (List Code) Code (List Code)]) + (case tokens' + (^ (list& [_ (#Form (list& [_ (#Identifier name)] args))] [meta_rec_location (#Record meta_rec_parts)] sigs)) + (#Some name args [meta_rec_location (#Record meta_rec_parts)] sigs) + + (^ (list& [_ (#Identifier name)] [meta_rec_location (#Record meta_rec_parts)] sigs)) + (#Some name #Nil [meta_rec_location (#Record meta_rec_parts)] sigs) + + (^ (list& [_ (#Form (list& [_ (#Identifier name)] args))] sigs)) + (#Some name args (` {}) sigs) + + (^ (list& [_ (#Identifier name)] sigs)) + (#Some name #Nil (` {}) sigs) + + _ + #None))] + (case ?parts + (#Some name args meta sigs) + (do meta_monad + [name+ (normalize name) + sigs' (monad\map meta_monad macro_expand sigs) + members (: (Meta (List [Text Code])) + (monad\map meta_monad + (: (-> Code (Meta [Text Code])) + (function (_ token) + (case token + (^ [_ (#Form (list [_ (#Text "lux type check")] type [_ (#Identifier ["" name])]))]) + (wrap [name type]) + + _ + (fail "Signatures require typed members!")))) + (list\join sigs'))) + #let [[_module _name] name+ + def_name (identifier$ name) + sig_type (record$ (list\map (: (-> [Text Code] [Code Code]) + (function (_ [m_name m_type]) + [(local_tag$ m_name) m_type])) + members)) + sig_meta (meta_code_merge (` {#.sig? #1}) + meta) + usage (case args + #Nil + def_name + + _ + (` ((~ def_name) (~+ args))))]] + (return (list (` (..type: (~+ (export exported?)) (~ usage) (~ sig_meta) (~ sig_type)))))) + + #None + (fail "Wrong syntax for interface:")))) + +(def: (find f xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #Nil + #None + + (#Cons x xs') + (case (f x) + #None + (find f xs') + + (#Some y) + (#Some y)))) + +(template [<name> <form> <message> <doc_msg>] + [(macro: #export (<name> tokens) + {#.doc <doc_msg>} + (case (list\reverse tokens) + (^ (list& last init)) + (return (list (list\fold (: (-> Code Code Code) + (function (_ pre post) (` <form>))) + last + init))) + + _ + (fail <message>)))] + + [and (if (~ pre) (~ post) #0) "'and' requires >=1 clauses." "Short-circuiting 'and': (and #1 #0 #1) ## => #0"] + [or (if (~ pre) #1 (~ post)) "'or' requires >=1 clauses." "Short-circuiting 'or': (or #1 #0 #1) ## => #1"]) + +(def: (index_of part text) + (-> Text Text (Maybe Nat)) + ("lux text index" 0 part text)) + +(def: #export (error! message) + {#.doc (text$ ($_ "lux text concat" + "## Causes an error, with the given error message." ..\n + "(error! ''OH NO!'')"))} + (-> Text Nothing) + ("lux io error" message)) + +(macro: (default tokens state) + {#.doc (text$ ($_ "lux text concat" + "## Allows you to provide a default value that will be used" ..\n + "## if a (Maybe x) value turns out to be #.None." + __paragraph + "(default +20 (#.Some +10)) ## => +10" + __paragraph + "(default +20 #.None) ## => +20"))} + (case tokens + (^ (list else maybe)) + (let [g!temp (: Code [dummy_location (#Identifier ["" ""])]) + code (` (case (~ maybe) + (#.Some (~ g!temp)) + (~ g!temp) + + #.None + (~ else)))] + (#Right [state (list code)])) + + _ + (#Left "Wrong syntax for default"))) + +(def: (text\split_all_with splitter input) + (-> Text Text (List Text)) + (case (..index_of splitter input) + #None + (list input) + + (#Some idx) + (list& ("lux text clip" 0 idx input) + (text\split_all_with splitter + (let [after_offset ("lux i64 +" 1 idx) + after_length ("lux i64 -" + after_offset + ("lux text size" input))] + ("lux text clip" after_offset after_length input)))))) + +(def: (nth idx xs) + (All [a] + (-> Nat (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons x xs') + (if ("lux i64 =" 0 idx) + (#Some x) + (nth ("lux i64 -" 1 idx) xs') + ))) + +(def: (beta_reduce env type) + (-> (List Type) Type Type) + (case type + (#Sum left right) + (#Sum (beta_reduce env left) (beta_reduce env right)) + + (#Product left right) + (#Product (beta_reduce env left) (beta_reduce env right)) + + (#Apply arg func) + (#Apply (beta_reduce env arg) (beta_reduce env func)) + + (#UnivQ ?local_env ?local_def) + (case ?local_env + #Nil + (#UnivQ env ?local_def) + + _ + type) + + (#ExQ ?local_env ?local_def) + (case ?local_env + #Nil + (#ExQ env ?local_def) + + _ + type) + + (#Function ?input ?output) + (#Function (beta_reduce env ?input) (beta_reduce env ?output)) + + (#Parameter idx) + (case (nth idx env) + (#Some parameter) + parameter + + _ + type) + + (#Named name type) + (beta_reduce env type) + + _ + type + )) + +(def: (apply_type type_fn param) + (-> Type Type (Maybe Type)) + (case type_fn + (#UnivQ env body) + (#Some (beta_reduce (list& type_fn param env) body)) + + (#ExQ env body) + (#Some (beta_reduce (list& type_fn param env) body)) + + (#Apply A F) + (do maybe_monad + [type_fn* (apply_type F A)] + (apply_type type_fn* param)) + + (#Named name type) + (apply_type type param) + + _ + #None)) + +(template [<name> <tag>] + [(def: (<name> type) + (-> Type (List Type)) + (case type + (<tag> left right) + (list& left (<name> right)) + + _ + (list type)))] + + [flatten_variant #Sum] + [flatten_tuple #Product] + [flatten_lambda #Function] + ) + +(def: (flatten_app type) + (-> Type [Type (List Type)]) + (case type + (#Apply head func') + (let [[func tail] (flatten_app func')] + [func (#Cons head tail)]) + + _ + [type (list)])) + +(def: (resolve_struct_type type) + (-> Type (Maybe (List Type))) + (case type + (#Product _) + (#Some (flatten_tuple type)) + + (#Apply arg func) + (do maybe_monad + [output (apply_type func arg)] + (resolve_struct_type output)) + + (#UnivQ _ body) + (resolve_struct_type body) + + (#ExQ _ body) + (resolve_struct_type body) + + (#Named name type) + (resolve_struct_type type) + + (#Sum _) + #None + + _ + (#Some (list type)))) + +(def: (find_module name) + (-> Text (Meta Module)) + (function (_ state) + (let [{#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} state] + (case (get name modules) + (#Some module) + (#Right state module) + + _ + (#Left ($_ text\compose "Unknown module: " name)))))) + +(def: get_current_module + (Meta Module) + (do meta_monad + [module_name current_module_name] + (find_module module_name))) + +(def: (resolve_tag [module name]) + (-> Name (Meta [Nat (List Name) Bit Type])) + (do meta_monad + [=module (find_module module) + #let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags_table #types types #module_annotations _ #module_state _} =module]] + (case (get name tags_table) + (#Some output) + (return output) + + _ + (fail (text\compose "Unknown tag: " (name\encode [module name])))))) + +(def: (resolve_type_tags type) + (-> Type (Meta (Maybe [(List Name) (List Type)]))) + (case type + (#Apply arg func) + (resolve_type_tags func) + + (#UnivQ env body) + (resolve_type_tags body) + + (#ExQ env body) + (resolve_type_tags body) + + (#Named [module name] unnamed) + (do meta_monad + [=module (find_module module) + #let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags #types types #module_annotations _ #module_state _} =module]] + (case (get name types) + (#Some [tags exported? (#Named _ _type)]) + (case (resolve_struct_type _type) + (#Some members) + (return (#Some [tags members])) + + _ + (return #None)) + + _ + (resolve_type_tags unnamed))) + + _ + (return #None))) + +(def: get_expected_type + (Meta Type) + (function (_ state) + (let [{#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} state] + (case expected + (#Some type) + (#Right state type) + + #None + (#Left "Not expecting any type."))))) + +(macro: #export (implementation tokens) + {#.doc "Not meant to be used directly. Prefer 'implementation:'."} + (do meta_monad + [tokens' (monad\map meta_monad macro_expand tokens) + struct_type get_expected_type + tags+type (resolve_type_tags struct_type) + tags (: (Meta (List Name)) + (case tags+type + (#Some [tags _]) + (return tags) + + _ + (fail "No tags available for type."))) + #let [tag_mappings (: (List [Text Code]) + (list\map (function (_ tag) [(second tag) (tag$ tag)]) + tags))] + members (monad\map meta_monad + (: (-> Code (Meta [Code Code])) + (function (_ token) + (case token + (^ [_ (#Form (list [_ (#Text "lux def")] [_ (#Identifier "" tag_name)] value meta [_ (#Bit #0)]))]) + (case (get tag_name tag_mappings) + (#Some tag) + (wrap [tag value]) + + _ + (fail (text\compose "Unknown implementation member: " tag_name))) + + _ + (fail "Invalid implementation member.")))) + (list\join tokens'))] + (wrap (list (record$ members))))) + +(def: (text\join_with separator parts) + (-> Text (List Text) Text) + (case parts + #Nil + "" + + (#Cons head tail) + (list\fold (function (_ right left) + ($_ text\compose left separator right)) + head + tail))) + +(macro: #export (implementation: tokens) + {#.doc (text$ ($_ "lux text concat" + "## Definition of structures ala ML." ..\n + "(implementation: #export order (Order Int)" ..\n + " (def: &equivalence equivalence)" ..\n + " (def: (< test subject)" ..\n + " (< test subject))" ..\n + " (def: (<= test subject)" ..\n + " (or (< test subject)" ..\n + " (= test subject)))" ..\n + " (def: (> test subject)" ..\n + " (> test subject))" ..\n + " (def: (>= test subject)" ..\n + " (or (> test subject)" ..\n + " (= test subject))))"))} + (let [[exported? tokens'] (export^ tokens) + ?parts (: (Maybe [Code (List Code) Code Code (List Code)]) + (case tokens' + (^ (list& [_ (#Form (list& name args))] [meta_rec_location (#Record meta_rec_parts)] type definitions)) + (#Some name args type [meta_rec_location (#Record meta_rec_parts)] definitions) + + (^ (list& name [meta_rec_location (#Record meta_rec_parts)] type definitions)) + (#Some name #Nil type [meta_rec_location (#Record meta_rec_parts)] definitions) + + (^ (list& [_ (#Form (list& name args))] type definitions)) + (#Some name args type (` {}) definitions) + + (^ (list& name type definitions)) + (#Some name #Nil type (` {}) definitions) + + _ + #None))] + (case ?parts + (#Some [name args type meta definitions]) + (let [usage (case args + #Nil + name + + _ + (` ((~ name) (~+ args))))] + (return (list (` (..def: (~+ (export exported?)) (~ usage) + (~ (meta_code_merge (` {#.implementation? #1}) + meta)) + (~ type) + (implementation (~+ definitions))))))) + + #None + (fail "Wrong syntax for implementation:")))) + +(def: (function\identity x) (All [a] (-> a a)) x) + +(macro: #export (type: tokens) + {#.doc (text$ ($_ "lux text concat" + "## The type-definition macro." ..\n + "(type: (List a) #Nil (#Cons a (List a)))"))} + (let [[exported? tokens'] (export^ tokens) + [rec? tokens'] (case tokens' + (#Cons [_ (#Tag [_ "rec"])] tokens') + [#1 tokens'] + + _ + [#0 tokens']) + parts (: (Maybe [Text (List Code) (List [Code Code]) (List Code)]) + (case tokens' + (^ (list [_ (#Identifier "" name)] [meta_location (#Record meta_parts)] [type_location (#Record type_parts)])) + (#Some [name #Nil meta_parts (list [type_location (#Record type_parts)])]) + + (^ (list& [_ (#Identifier "" name)] [meta_location (#Record meta_parts)] type_code1 type_codes)) + (#Some [name #Nil meta_parts (#Cons type_code1 type_codes)]) + + (^ (list& [_ (#Identifier "" name)] type_codes)) + (#Some [name #Nil (list) type_codes]) + + (^ (list [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta_location (#Record meta_parts)] [type_location (#Record type_parts)])) + (#Some [name args meta_parts (list [type_location (#Record type_parts)])]) + + (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta_location (#Record meta_parts)] type_code1 type_codes)) + (#Some [name args meta_parts (#Cons type_code1 type_codes)]) + + (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] type_codes)) + (#Some [name args (list) type_codes]) + + _ + #None))] + (case parts + (#Some name args meta type_codes) + (do meta_monad + [type+tags?? (unfold_type_def type_codes) + module_name current_module_name] + (let [type_name (local_identifier$ name) + [type tags??] type+tags?? + type' (: (Maybe Code) + (if rec? + (if (empty? args) + (let [g!param (local_identifier$ "") + prime_name (local_identifier$ name) + type+ (replace_syntax (list [name (` ((~ prime_name) .Nothing))]) type)] + (#Some (` ((All (~ prime_name) [(~ g!param)] (~ type+)) + .Nothing)))) + #None) + (case args + #Nil + (#Some type) + + _ + (#Some (` (.All (~ type_name) [(~+ args)] (~ type))))))) + total_meta (let [meta (process_def_meta meta) + meta (if rec? + (` (#.Cons (~ (flag_meta "type-rec?")) (~ meta))) + meta)] + (` [(~ location_code) + (#.Record (~ meta))]))] + (case type' + (#Some type'') + (let [typeC (` (#.Named [(~ (text$ module_name)) + (~ (text$ name))] + (.type (~ type''))))] + (return (list (case tags?? + (#Some tags) + (` ("lux def type tagged" (~ type_name) + (~ typeC) + (~ total_meta) + [(~+ (list\map text$ tags))] + (~ (bit$ exported?)))) + + _ + (` ("lux def" (~ type_name) + ("lux type check type" + (~ typeC)) + (~ total_meta) + (~ (bit$ exported?)))))))) + + #None + (fail "Wrong syntax for type:")))) + + #None + (fail "Wrong syntax for type:")) + )) + +(template [<name> <to>] + [(def: #export (<name> value) + (-> (I64 Any) <to>) + (:as <to> value))] + + [i64 I64] + [nat Nat] + [int Int] + [rev Rev] + ) + +(type: Referrals + #All + (#Only (List Text)) + (#Exclude (List Text)) + #Ignore + #Nothing) + +(type: Openings + [Text (List Text)]) + +(type: Refer + {#refer_defs Referrals + #refer_open (List Openings)}) + +(type: Importation + {#import_name Text + #import_alias (Maybe Text) + #import_refer Refer}) + +(def: (extract_defs defs) + (-> (List Code) (Meta (List Text))) + (monad\map meta_monad + (: (-> Code (Meta Text)) + (function (_ def) + (case def + [_ (#Identifier ["" name])] + (return name) + + _ + (fail "#only/#+ and #exclude/#- require identifiers.")))) + defs)) + +(def: (parse_referrals tokens) + (-> (List Code) (Meta [Referrals (List Code)])) + (case tokens + (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "+"])] defs))] tokens')) + (^ (list& [_ (#Form (list& [_ (#Tag ["" "only"])] defs))] tokens'))) + (do meta_monad + [defs' (extract_defs defs)] + (wrap [(#Only defs') tokens'])) + + (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "-"])] defs))] tokens')) + (^ (list& [_ (#Form (list& [_ (#Tag ["" "exclude"])] defs))] tokens'))) + (do meta_monad + [defs' (extract_defs defs)] + (wrap [(#Exclude defs') tokens'])) + + (^or (^ (list& [_ (#Tag ["" "*"])] tokens')) + (^ (list& [_ (#Tag ["" "all"])] tokens'))) + (return [#All tokens']) + + (^or (^ (list& [_ (#Tag ["" "_"])] tokens')) + (^ (list& [_ (#Tag ["" "nothing"])] tokens'))) + (return [#Ignore tokens']) + + _ + (return [#Nothing tokens]))) + +(def: (parse_openings parts) + (-> (List Code) (Meta [(List Openings) (List Code)])) + (case parts + #.Nil + (return [#.Nil #.Nil]) + + (^ (list& [_ (#Form (list& [_ (#Text prefix)] structs))] parts')) + (do meta_monad + [structs' (monad\map meta_monad + (function (_ struct) + (case struct + [_ (#Identifier ["" struct_name])] + (return struct_name) + + _ + (fail "Expected all implementations of opening form to be identifiers."))) + structs) + next+remainder (parse_openings parts')] + (let [[next remainder] next+remainder] + (return [(#.Cons [prefix structs'] next) + remainder]))) + + _ + (return [#.Nil parts]))) + +(def: (text\split! at x) + (-> Nat Text [Text Text]) + [("lux text clip" 0 at x) + ("lux text clip" at (|> x "lux text size" ("lux i64 -" at)) x)]) + +(def: (text\split_with token sample) + (-> Text Text (Maybe [Text Text])) + (do ..maybe_monad + [index (..index_of token sample) + #let [[pre post'] (text\split! index sample) + [_ post] (text\split! ("lux text size" token) post')]] + (wrap [pre post]))) + +(def: (replace_all pattern replacement template) + (-> Text Text Text Text) + ((: (-> Text Text Text) + (function (recur left right) + (case (..text\split_with pattern right) + (#.Some [pre post]) + (recur ($_ "lux text concat" left pre replacement) post) + + #.None + ("lux text concat" left right)))) + "" template)) + +(def: contextual_reference "#") +(def: self_reference ".") + +(def: (de_alias context self aliased) + (-> Text Text Text Text) + (|> aliased + (replace_all ..self_reference self) + (replace_all ..contextual_reference context))) + +(def: #export module_separator + "/") + +(def: parallel_hierarchy_sigil + "\") + +(def: (normalize_parallel_path' hierarchy root) + (-> Text Text Text) + (case [(text\split_with ..module_separator hierarchy) + (text\split_with ..parallel_hierarchy_sigil root)] + [(#.Some [_ hierarchy']) + (#.Some ["" root'])] + (normalize_parallel_path' hierarchy' root') + + _ + (case root + "" hierarchy + _ ($_ text\compose root ..module_separator hierarchy)))) + +(def: (normalize_parallel_path hierarchy root) + (-> Text Text (Maybe Text)) + (case (text\split_with ..parallel_hierarchy_sigil root) + (#.Some ["" root']) + (#.Some (normalize_parallel_path' hierarchy root')) + + _ + #.None)) + +(def: (count_relatives relatives input) + (-> Nat Text Nat) + (case ("lux text index" relatives ..module_separator input) + #None + relatives + + (#Some found) + (if ("lux i64 =" relatives found) + (count_relatives ("lux i64 +" 1 relatives) input) + relatives))) + +(def: (list\take amount list) + (All [a] (-> Nat (List a) (List a))) + (case [amount list] + (^or [0 _] [_ #Nil]) + #Nil + + [_ (#Cons head tail)] + (#Cons head (list\take ("lux i64 -" 1 amount) tail)))) + +(def: (list\drop amount list) + (All [a] (-> Nat (List a) (List a))) + (case [amount list] + (^or [0 _] [_ #Nil]) + list + + [_ (#Cons _ tail)] + (list\drop ("lux i64 -" 1 amount) tail))) + +(def: (clean_module nested? relative_root module) + (-> Bit Text Text (Meta Text)) + (case (count_relatives 0 module) + 0 + (return (if nested? + ($_ "lux text concat" relative_root ..module_separator module) + module)) + + relatives + (let [parts (text\split_all_with ..module_separator relative_root) + jumps ("lux i64 -" 1 relatives)] + (if (n/< (list\size parts) jumps) + (let [prefix (|> parts + list\reverse + (list\drop jumps) + list\reverse + (interpose ..module_separator) + (text\join_with "")) + clean ("lux text clip" relatives (|> module "lux text size" ("lux i64 -" relatives)) module) + output (case ("lux text size" clean) + 0 prefix + _ ($_ text\compose prefix ..module_separator clean))] + (return output)) + (fail ($_ "lux text concat" + "Cannot climb the module hierarchy..." ..\n + "Importing module: " module ..\n + " Relative Root: " relative_root ..\n)))))) + +(def: (alter_domain alteration domain import) + (-> Nat Text Importation Importation) + (let [[import_name import_alias import_refer] import + original (text\split_all_with ..module_separator import_name) + truncated (list\drop (.nat alteration) original) + parallel (case domain + "" + truncated + + _ + (list& domain truncated))] + {#import_name (text\join_with ..module_separator parallel) + #import_alias import_alias + #import_refer import_refer})) + +(def: (parse_imports nested? relative_root context_alias imports) + (-> Bit Text Text (List Code) (Meta (List Importation))) + (do meta_monad + [imports' (monad\map meta_monad + (: (-> Code (Meta (List Importation))) + (function (_ token) + (case token + ## Simple + [_ (#Identifier ["" m_name])] + (do meta_monad + [m_name (clean_module nested? relative_root m_name)] + (wrap (list {#import_name m_name + #import_alias #None + #import_refer {#refer_defs #All + #refer_open (list)}}))) + + ## Nested + (^ [_ (#Tuple (list& [_ (#Identifier ["" m_name])] extra))]) + (do meta_monad + [import_name (case (normalize_parallel_path relative_root m_name) + (#.Some parallel_path) + (wrap parallel_path) + + #.None + (clean_module nested? relative_root m_name)) + referral+extra (parse_referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse_openings extra) + #let [[openings extra] openings+extra] + sub_imports (parse_imports #1 import_name context_alias extra)] + (wrap (case [referral openings] + [#Nothing #Nil] + sub_imports + + _ + (list& {#import_name import_name + #import_alias #None + #import_refer {#refer_defs referral + #refer_open openings}} + sub_imports)))) + + (^ [_ (#Tuple (list& [_ (#Text alias)] [_ (#Identifier ["" m_name])] extra))]) + (do meta_monad + [import_name (case (normalize_parallel_path relative_root m_name) + (#.Some parallel_path) + (wrap parallel_path) + + #.None + (clean_module nested? relative_root m_name)) + referral+extra (parse_referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse_openings extra) + #let [[openings extra] openings+extra + de_aliased (de_alias context_alias m_name alias)] + sub_imports (parse_imports #1 import_name de_aliased extra)] + (wrap (case [referral openings] + [#Ignore #Nil] + sub_imports + + _ + (list& {#import_name import_name + #import_alias (#Some de_aliased) + #import_refer {#refer_defs referral + #refer_open openings}} + sub_imports)))) + + ## Unrecognized syntax. + _ + (do meta_monad + [current_module current_module_name] + (fail ($_ text\compose + "Wrong syntax for import @ " current_module + ..\n (code\encode token))))))) + imports)] + (wrap (list\join imports')))) + +(def: (exported_definitions module state) + (-> Text (Meta (List Text))) + (let [[current_module modules] (case state + {#info info #source source #current_module current_module #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} + [current_module modules])] + (case (get module modules) + (#Some =module) + (let [to_alias (list\map (: (-> [Text Global] + (List Text)) + (function (_ [name definition]) + (case definition + (#Left _) + (list) + + (#Right [exported? def_type def_meta def_value]) + (if exported? + (list name) + (list))))) + (let [{#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _} =module] + definitions))] + (#Right state (list\join to_alias))) + + #None + (#Left ($_ text\compose + "Unknown module: " (text\encode module) ..\n + "Current module: " (case current_module + (#Some current_module) + (text\encode current_module) + + #None + "???") ..\n + "Known modules: " (|> modules + (list\map (function (_ [name module]) + (text$ name))) + tuple$ + code\encode)))) + )) + +(def: (filter p xs) + (All [a] (-> (-> a Bit) (List a) (List a))) + (case xs + #Nil + (list) + + (#Cons x xs') + (if (p x) + (#Cons x (filter p xs')) + (filter p xs')))) + +(def: (is_member? cases name) + (-> (List Text) Text Bit) + (let [output (list\fold (function (_ case prev) + (or prev + (text\= case name))) + #0 + cases)] + output)) + +(def: (try_both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #None (f x2) + (#Some y) (#Some y))) + +(def: (find_in_env name state) + (-> Text Lux (Maybe Type)) + (case state + {#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} + (find (: (-> Scope (Maybe Type)) + (function (_ env) + (case env + {#name _ + #inner _ + #locals {#counter _ #mappings locals} + #captured {#counter _ #mappings closure}} + (try_both (find (: (-> [Text [Type Any]] (Maybe Type)) + (function (_ [bname [type _]]) + (if (text\= name bname) + (#Some type) + #None)))) + (: (List [Text [Type Any]]) locals) + (: (List [Text [Type Any]]) closure))))) + scopes))) + +(def: (find_def_type name state) + (-> Name Lux (Maybe Type)) + (let [[v_prefix v_name] name + {#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} state] + (case (get v_prefix modules) + #None + #None + + (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _}) + (case (get v_name definitions) + #None + #None + + (#Some definition) + (case definition + (#Left de_aliased) + (find_def_type de_aliased state) + + (#Right [exported? def_type def_meta def_value]) + (#Some def_type)))))) + +(def: (find_def_value name state) + (-> Name (Meta [Type Any])) + (let [[v_prefix v_name] name + {#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} state] + (case (get v_prefix modules) + #None + (#Left (text\compose "Unknown definition: " (name\encode name))) + + (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _}) + (case (get v_name definitions) + #None + (#Left (text\compose "Unknown definition: " (name\encode name))) + + (#Some definition) + (case definition + (#Left de_aliased) + (find_def_value de_aliased state) + + (#Right [exported? def_type def_meta def_value]) + (#Right [state [def_type def_value]])))))) + +(def: (find_type_var idx bindings) + (-> Nat (List [Nat (Maybe Type)]) (Maybe Type)) + (case bindings + #Nil + #Nil + + (#Cons [var bound] bindings') + (if ("lux i64 =" idx var) + bound + (find_type_var idx bindings')))) + +(def: (find_type full_name) + (-> Name (Meta Type)) + (do meta_monad + [#let [[module name] full_name] + current_module current_module_name] + (function (_ compiler) + (let [temp (if (text\= "" module) + (case (find_in_env name compiler) + (#Some struct_type) + (#Right [compiler struct_type]) + + _ + (case (find_def_type [current_module name] compiler) + (#Some struct_type) + (#Right [compiler struct_type]) + + _ + (#Left ($_ text\compose "Unknown var: " (name\encode full_name))))) + (case (find_def_type full_name compiler) + (#Some struct_type) + (#Right [compiler struct_type]) + + _ + (#Left ($_ text\compose "Unknown var: " (name\encode full_name)))))] + (case temp + (#Right [compiler (#Var type_id)]) + (let [{#info _ #source _ #current_module _ #modules _ + #scopes _ #type_context type_context #host _ + #seed _ #expected _ #location _ #extensions extensions + #scope_type_vars _} compiler + {#ex_counter _ #var_counter _ #var_bindings var_bindings} type_context] + (case (find_type_var type_id var_bindings) + #None + temp + + (#Some actualT) + (#Right [compiler actualT]))) + + _ + temp)) + ))) + +(def: (zip/2 xs ys) + (All [a b] (-> (List a) (List b) (List [a b]))) + (case xs + (#Cons x xs') + (case ys + (#Cons y ys') + (list& [x y] (zip/2 xs' ys')) + + _ + (list)) + + _ + (list))) + +(def: (type\encode type) + (-> Type Text) + (case type + (#Primitive name params) + (case params + #Nil + name + + _ + ($_ text\compose "(" name " " (|> params (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")")) + + (#Sum _) + ($_ text\compose "(| " (|> (flatten_variant type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")") + + (#Product _) + ($_ text\compose "[" (|> (flatten_tuple type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) "]") + + (#Function _) + ($_ text\compose "(-> " (|> (flatten_lambda type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")") + + (#Parameter id) + (nat\encode id) + + (#Var id) + ($_ text\compose "⌈v:" (nat\encode id) "⌋") + + (#Ex id) + ($_ text\compose "⟨e:" (nat\encode id) "⟩") + + (#UnivQ env body) + ($_ text\compose "(All " (type\encode body) ")") + + (#ExQ env body) + ($_ text\compose "(Ex " (type\encode body) ")") + + (#Apply _) + (let [[func args] (flatten_app type)] + ($_ text\compose + "(" (type\encode func) " " + (|> args (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) + ")")) + + (#Named name _) + (name\encode name) + )) + +(macro: #export (^open tokens) + {#.doc (text$ ($_ "lux text concat" + "## Same as the 'open' macro, but meant to be used as a pattern-matching macro for generating local bindings." ..\n + "## Takes an 'alias' text for the generated local bindings." ..\n + "(def: #export (range (^open ''.'') from to)" ..\n + " (All [a] (-> (Enum a) a a (List a)))" ..\n + " (range' <= succ from to))"))} + (case tokens + (^ (list& [_ (#Form (list [_ (#Text alias)]))] body branches)) + (do meta_monad + [g!temp (gensym "temp")] + (wrap (list& g!temp (` (..^open (~ g!temp) (~ (text$ alias)) (~ body))) branches))) + + (^ (list [_ (#Identifier name)] [_ (#Text alias)] body)) + (do meta_monad + [init_type (find_type name) + struct_evidence (resolve_type_tags init_type)] + (case struct_evidence + #None + (fail (text\compose "Can only 'open' structs: " (type\encode init_type))) + + (#Some tags&members) + (do meta_monad + [full_body ((: (-> Name [(List Name) (List Type)] Code (Meta Code)) + (function (recur source [tags members] target) + (let [locals (list\map (function (_ [t_module t_name]) + ["" (de_alias "" t_name alias)]) + tags) + pattern (tuple$ (list\map identifier$ locals))] + (do meta_monad + [enhanced_target (monad\fold meta_monad + (function (_ [m_local m_type] enhanced_target) + (do meta_monad + [m_implementation (resolve_type_tags m_type)] + (case m_implementation + (#Some m_tags&members) + (recur m_local + m_tags&members + enhanced_target) + + #None + (wrap enhanced_target)))) + target + (zip/2 locals members))] + (wrap (` ({(~ pattern) (~ enhanced_target)} (~ (identifier$ source))))))))) + name tags&members body)] + (wrap (list full_body))))) + + _ + (fail "Wrong syntax for ^open"))) + +(macro: #export (cond tokens) + {#.doc (text$ ($_ "lux text concat" + "## Branching structures with multiple test conditions." ..\n + "(cond (even? num) ''even''" ..\n + " (odd? num) ''odd''" + __paragraph + " ## else_branch" ..\n + " ''???'')"))} + (if ("lux i64 =" 0 (n/% 2 (list\size tokens))) + (fail "cond requires an uneven number of arguments.") + (case (list\reverse tokens) + (^ (list& else branches')) + (return (list (list\fold (: (-> [Code Code] Code Code) + (function (_ branch else) + (let [[right left] branch] + (` (if (~ left) (~ right) (~ else)))))) + else + (as_pairs branches')))) + + _ + (fail "Wrong syntax for cond")))) + +(def: (enumeration' idx xs) + (All [a] (-> Nat (List a) (List [Nat a]))) + (case xs + (#Cons x xs') + (#Cons [idx x] (enumeration' ("lux i64 +" 1 idx) xs')) + + #Nil + #Nil)) + +(def: (enumeration xs) + (All [a] (-> (List a) (List [Nat a]))) + (enumeration' 0 xs)) + +(macro: #export (get@ tokens) + {#.doc (text$ ($_ "lux text concat" + "## Accesses the value of a record at a given tag." ..\n + "(get@ #field my_record)" + __paragraph + "## Can also work with multiple levels of nesting:" ..\n + "(get@ [#foo #bar #baz] my_record)" + __paragraph + "## And, if only the slot/path is given, generates an accessor function:" ..\n + "(let [getter (get@ [#foo #bar #baz])]" ..\n + " (getter my_record))"))} + (case tokens + (^ (list [_ (#Tag slot')] record)) + (do meta_monad + [slot (normalize slot') + output (resolve_tag slot) + #let [[idx tags exported? type] output] + g!_ (gensym "_") + g!output (gensym "")] + (case (resolve_struct_type type) + (#Some members) + (let [pattern (record$ (list\map (: (-> [Name [Nat Type]] [Code Code]) + (function (_ [[r_prefix r_name] [r_idx r_type]]) + [(tag$ [r_prefix r_name]) + (if ("lux i64 =" idx r_idx) + g!output + g!_)])) + (zip/2 tags (enumeration members))))] + (return (list (` ({(~ pattern) (~ g!output)} (~ record)))))) + + _ + (fail "get@ can only use records."))) + + (^ (list [_ (#Tuple slots)] record)) + (return (list (list\fold (: (-> Code Code Code) + (function (_ slot inner) + (` (..get@ (~ slot) (~ inner))))) + record + slots))) + + (^ (list selector)) + (do meta_monad + [g!_ (gensym "_") + g!record (gensym "record")] + (wrap (list (` (function ((~ g!_) (~ g!record)) (..get@ (~ selector) (~ g!record))))))) + + _ + (fail "Wrong syntax for get@"))) + +(def: (open_field alias tags my_tag_index [module short] source type) + (-> Text (List Name) Nat Name Code Type (Meta (List Code))) + (do meta_monad + [output (resolve_type_tags type) + g!_ (gensym "g!_") + #let [g!output (local_identifier$ short) + pattern (|> tags + enumeration + (list\map (function (_ [tag_idx tag]) + (if ("lux i64 =" my_tag_index tag_idx) + g!output + g!_))) + tuple$) + source+ (` ({(~ pattern) (~ g!output)} (~ source)))]] + (case output + (#Some [tags' members']) + (do meta_monad + [decls' (monad\map meta_monad + (: (-> [Nat Name Type] (Meta (List Code))) + (function (_ [sub_tag_index sname stype]) + (open_field alias tags' sub_tag_index sname source+ stype))) + (enumeration (zip/2 tags' members')))] + (return (list\join decls'))) + + _ + (return (list (` ("lux def" (~ (local_identifier$ (de_alias "" short alias))) + (~ source+) + [(~ location_code) (#.Record #Nil)] + #0))))))) + +(macro: #export (open: tokens) + {#.doc (text$ ($_ "lux text concat" + "## Opens a implementation and generates a definition for each of its members (including nested members)." + __paragraph + "## For example:" ..\n + "(open: ''i:.'' number)" + __paragraph + "## Will generate:" ..\n + "(def: i:+ (\ number +))" ..\n + "(def: i:- (\ number -))" ..\n + "(def: i:* (\ number *))" ..\n + "..."))} + (case tokens + (^ (list [_ (#Text alias)] struct)) + (case struct + [_ (#Identifier struct_name)] + (do meta_monad + [struct_type (find_type struct_name) + output (resolve_type_tags struct_type) + #let [source (identifier$ struct_name)]] + (case output + (#Some [tags members]) + (do meta_monad + [decls' (monad\map meta_monad (: (-> [Nat Name Type] (Meta (List Code))) + (function (_ [tag_index sname stype]) + (open_field alias tags tag_index sname source stype))) + (enumeration (zip/2 tags members)))] + (return (list\join decls'))) + + _ + (fail (text\compose "Can only 'open:' structs: " (type\encode struct_type))))) + + _ + (do meta_monad + [g!struct (gensym "struct")] + (return (list (` ("lux def" (~ g!struct) (~ struct) + [(~ location_code) (#.Record #Nil)] + #0)) + (` (..open: (~ (text$ alias)) (~ g!struct))))))) + + _ + (fail "Wrong syntax for open:"))) + +(macro: #export (|>> tokens) + {#.doc (text$ ($_ "lux text concat" + "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..\n + "(|>> (list\map int\encode) (interpose '' '') (fold text\compose ''''))" ..\n + "## =>" ..\n + "(function (_ <arg>) (fold text\compose '''' (interpose '' '' (list\map int\encode <arg>))))"))} + (do meta_monad + [g!_ (gensym "_") + g!arg (gensym "arg")] + (return (list (` (function ((~ g!_) (~ g!arg)) (|> (~ g!arg) (~+ tokens)))))))) + +(macro: #export (<<| tokens) + {#.doc (text$ ($_ "lux text concat" + "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..\n + "(<<| (fold text\compose '''') (interpose '' '') (list\map int\encode))" ..\n + "## =>" ..\n + "(function (_ <arg>) (fold text\compose '''' (interpose '' '' (list\map int\encode <arg>))))"))} + (do meta_monad + [g!_ (gensym "_") + g!arg (gensym "arg")] + (return (list (` (function ((~ g!_) (~ g!arg)) (<| (~+ tokens) (~ g!arg)))))))) + +(def: (imported_by? import_name module_name) + (-> Text Text (Meta Bit)) + (do meta_monad + [module (find_module module_name) + #let [{#module_hash _ #module_aliases _ #definitions _ #imports imports #tags _ #types _ #module_annotations _ #module_state _} module]] + (wrap (is_member? imports import_name)))) + +(def: (read_refer module_name options) + (-> Text (List Code) (Meta Refer)) + (do meta_monad + [referral+options (parse_referrals options) + #let [[referral options] referral+options] + openings+options (parse_openings options) + #let [[openings options] openings+options] + current_module current_module_name] + (case options + #Nil + (wrap {#refer_defs referral + #refer_open openings}) + + _ + (fail ($_ text\compose "Wrong syntax for refer @ " current_module + ..\n (|> options + (list\map code\encode) + (interpose " ") + (list\fold text\compose ""))))))) + +(def: (write_refer module_name [r_defs r_opens]) + (-> Text Refer (Meta (List Code))) + (do meta_monad + [current_module current_module_name + #let [test_referrals (: (-> Text (List Text) (List Text) (Meta (List Any))) + (function (_ module_name all_defs referred_defs) + (monad\map meta_monad + (: (-> Text (Meta Any)) + (function (_ _def) + (if (is_member? all_defs _def) + (return []) + (fail ($_ text\compose _def " is not defined in module " module_name " @ " current_module))))) + referred_defs)))] + defs' (case r_defs + #All + (exported_definitions module_name) + + (#Only +defs) + (do meta_monad + [*defs (exported_definitions module_name) + _ (test_referrals module_name *defs +defs)] + (wrap +defs)) + + (#Exclude _defs) + (do meta_monad + [*defs (exported_definitions module_name) + _ (test_referrals module_name *defs _defs)] + (wrap (filter (|>> (is_member? _defs) not) *defs))) + + #Ignore + (wrap (list)) + + #Nothing + (wrap (list))) + #let [defs (list\map (: (-> Text Code) + (function (_ def) + (` ("lux def alias" (~ (local_identifier$ def)) (~ (identifier$ [module_name def])))))) + defs') + openings (|> r_opens + (list\map (: (-> Openings (List Code)) + (function (_ [alias structs]) + (list\map (function (_ name) + (` (open: (~ (text$ alias)) (~ (identifier$ [module_name name]))))) + structs)))) + list\join)]] + (wrap (list\compose defs openings)) + )) + +(macro: #export (refer tokens) + (case tokens + (^ (list& [_ (#Text module_name)] options)) + (do meta_monad + [=refer (read_refer module_name options)] + (write_refer module_name =refer)) + + _ + (fail "Wrong syntax for refer"))) + +(def: (refer_to_code module_name module_alias' [r_defs r_opens]) + (-> Text (Maybe Text) Refer Code) + (let [module_alias (..default module_name module_alias') + localizations (: (List Code) + (case r_defs + #All + (list (' #*)) + + (#Only defs) + (list (form$ (list& (' #+) (list\map local_identifier$ defs)))) + + (#Exclude defs) + (list (form$ (list& (' #-) (list\map local_identifier$ defs)))) + + #Ignore + (list) + + #Nothing + (list))) + openings (list\map (function (_ [alias structs]) + (form$ (list& (text$ (..replace_all ..contextual_reference module_alias alias)) + (list\map local_identifier$ structs)))) + r_opens)] + (` (..refer (~ (text$ module_name)) + (~+ localizations) + (~+ openings))))) + +(macro: #export (module: tokens) + {#.doc (text$ ($_ "lux text concat" + "## Module_definition macro." + __paragraph + "## Can take optional annotations and allows the specification of modules to import." + __paragraph + "## Example" ..\n + "(.module: {#.doc ''Some documentation...''}" ..\n + " [lux #*" ..\n + " [control" ..\n + " [''M'' monad #*]]" ..\n + " [data" ..\n + " maybe" ..\n + " [''.'' name (''#/.'' codec)]]" ..\n + " [macro" ..\n + " code]]" ..\n + " [//" ..\n + " [type (''.'' equivalence)]])"))} + (do meta_monad + [#let [[_meta _imports] (: [(List [Code Code]) (List Code)] + (case tokens + (^ (list& [_ (#Record _meta)] _imports)) + [_meta _imports] + + _ + [(list) tokens]))] + current_module current_module_name + imports (parse_imports #0 current_module "" _imports) + #let [=imports (|> imports + (list\map (: (-> Importation Code) + (function (_ [m_name m_alias =refer]) + (` [(~ (text$ m_name)) (~ (text$ (default "" m_alias)))])))) + tuple$) + =refers (list\map (: (-> Importation Code) + (function (_ [m_name m_alias =refer]) + (refer_to_code m_name m_alias =refer))) + imports) + =module (` ("lux def module" [(~ location_code) + (#.Record (~ (process_def_meta _meta)))] + (~ =imports)))]] + (wrap (#Cons =module =refers)))) + +(macro: #export (\ tokens) + {#.doc (text$ ($_ "lux text concat" + "## Allows accessing the value of a implementation's member." ..\n + "(\ codec encode)" + __paragraph + "## Also allows using that value as a function." ..\n + "(\ codec encode +123)"))} + (case tokens + (^ (list struct [_ (#Identifier member)])) + (return (list (` (let [(^open (~ (text$ ..self_reference))) (~ struct)] (~ (identifier$ member)))))) + + (^ (list& struct member args)) + (return (list (` ((..\ (~ struct) (~ member)) (~+ args))))) + + _ + (fail "Wrong syntax for \"))) + +(macro: #export (set@ tokens) + {#.doc (text$ ($_ "lux text concat" + "## Sets the value of a record at a given tag." ..\n + "(set@ #name ''Lux'' lang)" + __paragraph + "## Can also work with multiple levels of nesting:" ..\n + "(set@ [#foo #bar #baz] value my_record)" + __paragraph + "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..\n + "(let [setter (set@ [#foo #bar #baz] value)] (setter my_record))" ..\n + "(let [setter (set@ [#foo #bar #baz])] (setter value my_record))"))} + (case tokens + (^ (list [_ (#Tag slot')] value record)) + (do meta_monad + [slot (normalize slot') + output (resolve_tag slot) + #let [[idx tags exported? type] output]] + (case (resolve_struct_type type) + (#Some members) + (do meta_monad + [pattern' (monad\map meta_monad + (: (-> [Name [Nat Type]] (Meta [Name Nat Code])) + (function (_ [r_slot_name [r_idx r_type]]) + (do meta_monad + [g!slot (gensym "")] + (return [r_slot_name r_idx g!slot])))) + (zip/2 tags (enumeration members)))] + (let [pattern (record$ (list\map (: (-> [Name Nat Code] [Code Code]) + (function (_ [r_slot_name r_idx r_var]) + [(tag$ r_slot_name) + r_var])) + pattern')) + output (record$ (list\map (: (-> [Name Nat Code] [Code Code]) + (function (_ [r_slot_name r_idx r_var]) + [(tag$ r_slot_name) + (if ("lux i64 =" idx r_idx) + value + r_var)])) + pattern'))] + (return (list (` ({(~ pattern) (~ output)} (~ record))))))) + + _ + (fail "set@ can only use records."))) + + (^ (list [_ (#Tuple slots)] value record)) + (case slots + #Nil + (fail "Wrong syntax for set@") + + _ + (do meta_monad + [bindings (monad\map meta_monad + (: (-> Code (Meta Code)) + (function (_ _) (gensym "temp"))) + slots) + #let [pairs (zip/2 slots bindings) + update_expr (list\fold (: (-> [Code Code] Code Code) + (function (_ [s b] v) + (` (..set@ (~ s) (~ v) (~ b))))) + value + (list\reverse pairs)) + [_ accesses'] (list\fold (: (-> [Code Code] [Code (List (List Code))] [Code (List (List Code))]) + (function (_ [new_slot new_binding] [old_record accesses']) + [(` (get@ (~ new_slot) (~ new_binding))) + (#Cons (list new_binding old_record) accesses')])) + [record (: (List (List Code)) #Nil)] + pairs) + accesses (list\join (list\reverse accesses'))]] + (wrap (list (` (let [(~+ accesses)] + (~ update_expr))))))) + + (^ (list selector value)) + (do meta_monad + [g!_ (gensym "_") + g!record (gensym "record")] + (wrap (list (` (function ((~ g!_) (~ g!record)) + (..set@ (~ selector) (~ value) (~ g!record))))))) + + (^ (list selector)) + (do meta_monad + [g!_ (gensym "_") + g!value (gensym "value") + g!record (gensym "record")] + (wrap (list (` (function ((~ g!_) (~ g!value) (~ g!record)) + (..set@ (~ selector) (~ g!value) (~ g!record))))))) + + _ + (fail "Wrong syntax for set@"))) + +(macro: #export (update@ tokens) + {#.doc (text$ ($_ "lux text concat" + "## Modifies the value of a record at a given tag, based on some function." ..\n + "(update@ #age inc person)" + __paragraph + "## Can also work with multiple levels of nesting:" ..\n + "(update@ [#foo #bar #baz] func my_record)" + __paragraph + "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..\n + "(let [updater (update@ [#foo #bar #baz] func)] (updater my_record))" ..\n + "(let [updater (update@ [#foo #bar #baz])] (updater func my_record))"))} + (case tokens + (^ (list [_ (#Tag slot')] fun record)) + (do meta_monad + [slot (normalize slot') + output (resolve_tag slot) + #let [[idx tags exported? type] output]] + (case (resolve_struct_type type) + (#Some members) + (do meta_monad + [pattern' (monad\map meta_monad + (: (-> [Name [Nat Type]] (Meta [Name Nat Code])) + (function (_ [r_slot_name [r_idx r_type]]) + (do meta_monad + [g!slot (gensym "")] + (return [r_slot_name r_idx g!slot])))) + (zip/2 tags (enumeration members)))] + (let [pattern (record$ (list\map (: (-> [Name Nat Code] [Code Code]) + (function (_ [r_slot_name r_idx r_var]) + [(tag$ r_slot_name) + r_var])) + pattern')) + output (record$ (list\map (: (-> [Name Nat Code] [Code Code]) + (function (_ [r_slot_name r_idx r_var]) + [(tag$ r_slot_name) + (if ("lux i64 =" idx r_idx) + (` ((~ fun) (~ r_var))) + r_var)])) + pattern'))] + (return (list (` ({(~ pattern) (~ output)} (~ record))))))) + + _ + (fail "update@ can only use records."))) + + (^ (list [_ (#Tuple slots)] fun record)) + (case slots + #Nil + (fail "Wrong syntax for update@") + + _ + (do meta_monad + [g!record (gensym "record") + g!temp (gensym "temp")] + (wrap (list (` (let [(~ g!record) (~ record) + (~ g!temp) (get@ [(~+ slots)] (~ g!record))] + (set@ [(~+ slots)] ((~ fun) (~ g!temp)) (~ g!record)))))))) + + (^ (list selector fun)) + (do meta_monad + [g!_ (gensym "_") + g!record (gensym "record")] + (wrap (list (` (function ((~ g!_) (~ g!record)) + (..update@ (~ selector) (~ fun) (~ g!record))))))) + + (^ (list selector)) + (do meta_monad + [g!_ (gensym "_") + g!fun (gensym "fun") + g!record (gensym "record")] + (wrap (list (` (function ((~ g!_) (~ g!fun) (~ g!record)) + (..update@ (~ selector) (~ g!fun) (~ g!record))))))) + + _ + (fail "Wrong syntax for update@"))) + +(macro: #export (^template tokens) + {#.doc (text$ ($_ "lux text concat" + "## It's similar to template, but meant to be used during pattern-matching." ..\n + "(def: (beta_reduce env type)" ..\n + " (-> (List Type) Type Type)" ..\n + " (case type" ..\n + " (#.Primitive name params)" ..\n + " (#.Primitive name (list\map (beta_reduce env) params))" + __paragraph + " (^template [<tag>]" ..\n + " [(<tag> left right)" ..\n + " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..\n + " ([#.Sum] [#.Product])" + __paragraph + " (^template [<tag>]" ..\n + " [(<tag> left right)" ..\n + " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..\n + " ([#.Function] [#.Apply])" + __paragraph + " (^template [<tag>]" ..\n + " [(<tag> old_env def)" ..\n + " (case old_env" ..\n + " #.Nil" ..\n + " (<tag> env def)" + __paragraph + " _" ..\n + " type)])" ..\n + " ([#.UnivQ] [#.ExQ])" + __paragraph + " (#.Parameter idx)" ..\n + " (default type (list.nth idx env))" + __paragraph + " _" ..\n + " type" ..\n + " ))"))} + (case tokens + (^ (list& [_ (#Form (list [_ (#Tuple bindings)] + [_ (#Tuple templates)]))] + [_ (#Form data)] + branches)) + (case (: (Maybe (List Code)) + (do maybe_monad + [bindings' (monad\map maybe_monad get_short bindings) + data' (monad\map maybe_monad tuple->list data)] + (let [num_bindings (list\size bindings')] + (if (every? (|>> ("lux i64 =" num_bindings)) + (list\map list\size data')) + (let [apply (: (-> RepEnv (List Code)) + (function (_ env) (list\map (apply_template env) templates)))] + (|> data' + (list\map (compose apply (make_env bindings'))) + list\join + wrap)) + #None)))) + (#Some output) + (return (list\compose output branches)) + + #None + (fail "Wrong syntax for ^template")) + + _ + (fail "Wrong syntax for ^template"))) + +(def: (find_baseline_column code) + (-> Code Nat) + (case code + (^template [<tag>] + [[[_ _ column] (<tag> _)] + column]) + ([#Bit] + [#Nat] + [#Int] + [#Rev] + [#Frac] + [#Text] + [#Identifier] + [#Tag]) + + (^template [<tag>] + [[[_ _ column] (<tag> parts)] + (list\fold n/min column (list\map find_baseline_column parts))]) + ([#Form] + [#Tuple]) + + [[_ _ column] (#Record pairs)] + (list\fold n/min column + (list\compose (list\map (|>> first find_baseline_column) pairs) + (list\map (|>> second find_baseline_column) pairs))) + )) + +(type: Doc_Fragment + (#Doc_Comment Text) + (#Doc_Example Code)) + +(def: (identify_doc_fragment code) + (-> Code Doc_Fragment) + (case code + [_ (#Text comment)] + (#Doc_Comment comment) + + _ + (#Doc_Example code))) + +(template [<name> <extension> <doc>] + [(def: #export <name> + {#.doc <doc>} + (All [s] (-> (I64 s) (I64 s))) + (|>> (<extension> 1)))] + + [inc "lux i64 +" "Increment function."] + [dec "lux i64 -" "Decrement function."] + ) + +(def: tag\encode + (-> Name Text) + (|>> name\encode (text\compose "#"))) + +(def: (repeat n x) + (All [a] (-> Int a (List a))) + (if ("lux i64 <" n +0) + (#Cons x (repeat ("lux i64 +" -1 n) x)) + #Nil)) + +(def: (location_padding baseline [_ old_line old_column] [_ new_line new_column]) + (-> Nat Location Location Text) + (if ("lux i64 =" old_line new_line) + (text\join_with "" (repeat (.int ("lux i64 -" old_column new_column)) " ")) + (let [extra_lines (text\join_with "" (repeat (.int ("lux i64 -" old_line new_line)) ..\n)) + space_padding (text\join_with "" (repeat (.int ("lux i64 -" baseline new_column)) " "))] + (text\compose extra_lines space_padding)))) + +(def: (text\size x) + (-> Text Nat) + ("lux text size" x)) + +(def: (update_location [file line column] code_text) + (-> Location Text Location) + [file line ("lux i64 +" column (text\size code_text))]) + +(def: (delim_update_location [file line column]) + (-> Location Location) + [file line (inc column)]) + +(def: rejoin_all_pairs + (-> (List [Code Code]) (List Code)) + (|>> (list\map rejoin_pair) list\join)) + +(def: (doc_example->Text prev_location baseline example) + (-> Location Nat Code [Location Text]) + (case example + (^template [<tag> <encode>] + [[new_location (<tag> value)] + (let [as_text (<encode> value)] + [(update_location new_location as_text) + (text\compose (location_padding baseline prev_location new_location) + as_text)])]) + ([#Bit bit\encode] + [#Nat nat\encode] + [#Int int\encode] + [#Frac frac\encode] + [#Text text\encode] + [#Identifier name\encode] + [#Tag tag\encode]) + + (^template [<tag> <open> <close> <prep>] + [[group_location (<tag> parts)] + (let [[group_location' parts_text] (list\fold (function (_ part [last_location text_accum]) + (let [[part_location part_text] (doc_example->Text last_location baseline part)] + [part_location (text\compose text_accum part_text)])) + [(delim_update_location group_location) ""] + (<prep> parts))] + [(delim_update_location group_location') + ($_ text\compose (location_padding baseline prev_location group_location) + <open> + parts_text + <close>)])]) + ([#Form "(" ")" ..function\identity] + [#Tuple "[" "]" ..function\identity] + [#Record "{" "}" rejoin_all_pairs]) + + [new_location (#Rev value)] + ("lux io error" "@doc_example->Text Undefined behavior.") + )) + +(def: (with_baseline baseline [file line column]) + (-> Nat Location Location) + [file line baseline]) + +(def: (doc_fragment->Text fragment) + (-> Doc_Fragment Text) + (case fragment + (#Doc_Comment comment) + (|> comment + (text\split_all_with ..\n) + (list\map (function (_ line) ($_ text\compose "## " line ..\n))) + (text\join_with "")) + + (#Doc_Example example) + (let [baseline (find_baseline_column example) + [location _] example + [_ text] (doc_example->Text (with_baseline baseline location) baseline example)] + (text\compose text __paragraph)))) + +(macro: #export (doc tokens) + {#.doc (text$ ($_ "lux text concat" + "## Creates code documentation, embedding text as comments and properly formatting the forms it's being given." + __paragraph + "## For Example:" ..\n + "(doc ''Allows arbitrary looping, using the 'recur' form to re-start the loop.''" ..\n + " ''Can be used in monadic code to create monadic loops.''" ..\n + " (loop [count +0" ..\n + " x init]" ..\n + " (if (< +10 count)" ..\n + " (recur (inc count) (f x))" ..\n + " x)))"))} + (return (list (` [(~ location_code) + (#.Text (~ (|> tokens + (list\map (|>> identify_doc_fragment doc_fragment->Text)) + (text\join_with "") + text$)))])))) + +(def: (interleave xs ys) + (All [a] (-> (List a) (List a) (List a))) + (case xs + #Nil + #Nil + + (#Cons x xs') + (case ys + #Nil + #Nil + + (#Cons y ys') + (list& x y (interleave xs' ys'))))) + +(def: (type_to_code type) + (-> Type Code) + (case type + (#Primitive name params) + (` (#.Primitive (~ (text$ name)) (~ (untemplate_list (list\map type_to_code params))))) + + (^template [<tag>] + [(<tag> left right) + (` (<tag> (~ (type_to_code left)) (~ (type_to_code right))))]) + ([#.Sum] [#.Product] + [#.Function] + [#.Apply]) + + (^template [<tag>] + [(<tag> id) + (` (<tag> (~ (nat$ id))))]) + ([#.Parameter] [#.Var] [#.Ex]) + + (^template [<tag>] + [(<tag> env type) + (let [env' (untemplate_list (list\map type_to_code env))] + (` (<tag> (~ env') (~ (type_to_code type)))))]) + ([#.UnivQ] [#.ExQ]) + + (#Named [module name] anonymous) + ## TODO: Generate the explicit type definition instead of using + ## the "identifier$" shortcut below. + ## (` (#.Named [(~ (text$ module)) (~ (text$ name))] + ## (~ (type_to_code anonymous)))) + (identifier$ [module name]))) + +(macro: #export (loop tokens) + {#.doc (doc "Allows arbitrary looping, using the 'recur' form to re-start the loop." + "Can be used in monadic code to create monadic loops." + (loop [count +0 + x init] + (if (< +10 count) + (recur (inc count) (f x)) + x)) + + "Loops can also be given custom names." + (loop my_loop + [count +0 + x init] + (if (< +10 count) + (my_loop (inc count) (f x)) + x)))} + (let [?params (case tokens + (^ (list name [_ (#Tuple bindings)] body)) + (#.Some [name bindings body]) + + (^ (list [_ (#Tuple bindings)] body)) + (#.Some [(local_identifier$ "recur") bindings body]) + + _ + #.None)] + (case ?params + (#.Some [name bindings body]) + (let [pairs (as_pairs bindings) + vars (list\map first pairs) + inits (list\map second pairs)] + (if (every? identifier? inits) + (do meta_monad + [inits' (: (Meta (List Name)) + (case (monad\map maybe_monad get_name inits) + (#Some inits') (return inits') + #None (fail "Wrong syntax for loop"))) + init_types (monad\map meta_monad find_type inits') + expected get_expected_type] + (return (list (` (("lux type check" + (-> (~+ (list\map type_to_code init_types)) + (~ (type_to_code expected))) + (function ((~ name) (~+ vars)) + (~ body))) + (~+ inits)))))) + (do meta_monad + [aliases (monad\map meta_monad + (: (-> Code (Meta Code)) + (function (_ _) (gensym ""))) + inits)] + (return (list (` (let [(~+ (interleave aliases inits))] + (.loop (~ name) + [(~+ (interleave vars aliases))] + (~ body))))))))) + + #.None + (fail "Wrong syntax for loop")))) + +(macro: #export (^slots tokens) + {#.doc (doc "Allows you to extract record members as local variables with the same names." + "For example:" + (let [(^slots [#foo #bar #baz]) quux] + (f foo bar baz)))} + (case tokens + (^ (list& [_ (#Form (list [_ (#Tuple (list& hslot' tslots'))]))] body branches)) + (do meta_monad + [slots (: (Meta [Name (List Name)]) + (case (: (Maybe [Name (List Name)]) + (do maybe_monad + [hslot (get_tag hslot') + tslots (monad\map maybe_monad get_tag tslots')] + (wrap [hslot tslots]))) + (#Some slots) + (return slots) + + #None + (fail "Wrong syntax for ^slots"))) + #let [[hslot tslots] slots] + hslot (normalize hslot) + tslots (monad\map meta_monad normalize tslots) + output (resolve_tag hslot) + g!_ (gensym "_") + #let [[idx tags exported? type] output + slot_pairings (list\map (: (-> Name [Text Code]) + (function (_ [module name]) + [name (local_identifier$ name)])) + (list& hslot tslots)) + pattern (record$ (list\map (: (-> Name [Code Code]) + (function (_ [module name]) + (let [tag (tag$ [module name])] + (case (get name slot_pairings) + (#Some binding) [tag binding] + #None [tag g!_])))) + tags))]] + (return (list& pattern body branches))) + + _ + (fail "Wrong syntax for ^slots"))) + +(def: (place_tokens label tokens target) + (-> Text (List Code) Code (Maybe (List Code))) + (case target + (^or [_ (#Bit _)] [_ (#Nat _)] [_ (#Int _)] [_ (#Rev _)] [_ (#Frac _)] [_ (#Text _)] [_ (#Tag _)]) + (#Some (list target)) + + [_ (#Identifier [prefix name])] + (if (and (text\= "" prefix) + (text\= label name)) + (#Some tokens) + (#Some (list target))) + + (^template [<tag>] + [[location (<tag> elems)] + (do maybe_monad + [placements (monad\map maybe_monad (place_tokens label tokens) elems)] + (wrap (list [location (<tag> (list\join placements))])))]) + ([#Tuple] + [#Form]) + + [location (#Record pairs)] + (do maybe_monad + [=pairs (monad\map maybe_monad + (: (-> [Code Code] (Maybe [Code Code])) + (function (_ [slot value]) + (do maybe_monad + [slot' (place_tokens label tokens slot) + value' (place_tokens label tokens value)] + (case [slot' value'] + (^ [(list =slot) (list =value)]) + (wrap [=slot =value]) + + _ + #None)))) + pairs)] + (wrap (list [location (#Record =pairs)]))) + )) + +(macro: #export (with_expansions tokens) + {#.doc (doc "Controlled macro-expansion." + "Bind an arbitraty number of Code nodes resulting from macro-expansion to local bindings." + "Wherever a binding appears, the bound Code nodes will be spliced in there." + (test: "Code operations & implementations" + (with_expansions + [<tests> (template [<expr> <text>] + [(compare <text> (\ Code/encode encode <expr>))] + + [(bit #1) "#1"] + [(int +123) "+123"] + [(frac +123.0) "+123.0"] + [(text "123") "'123'"] + [(tag ["yolo" "lol"]) "#yolo.lol"] + [(identifier ["yolo" "lol"]) "yolo.lol"] + [(form (list (bit #1))) "(#1)"] + [(tuple (list (bit #1))) "[#1]"] + [(record (list [(bit #1) (int +123)])) "{#1 +123}"] + )] + (test_all <tests>))))} + (case tokens + (^ (list& [_ (#Tuple bindings)] bodies)) + (case bindings + (^ (list& [_ (#Identifier ["" var_name])] macro_expr bindings')) + (do meta_monad + [expansion (macro_expand_once macro_expr)] + (case (place_tokens var_name expansion (` (.with_expansions + [(~+ bindings')] + (~+ bodies)))) + (#Some output) + (wrap output) + + _ + (fail "[with_expansions] Improper macro expansion."))) + + #Nil + (return bodies) + + _ + (fail "Wrong syntax for with_expansions")) + + _ + (fail "Wrong syntax for with_expansions"))) + +(def: (flatten_alias type) + (-> Type Type) + (case type + (^template [<name>] + [(#Named ["library/lux" <name>] _) + type]) + (["Bit"] + ["Nat"] + ["Int"] + ["Rev"] + ["Frac"] + ["Text"]) + + (#Named _ type') + (flatten_alias type') + + _ + type)) + +(def: (anti_quote_def name) + (-> Name (Meta Code)) + (do meta_monad + [type+value (find_def_value name) + #let [[type value] type+value]] + (case (flatten_alias type) + (^template [<name> <type> <wrapper>] + [(#Named ["library/lux" <name>] _) + (wrap (<wrapper> (:as <type> value)))]) + (["Bit" Bit bit$] + ["Nat" Nat nat$] + ["Int" Int int$] + ["Rev" Rev rev$] + ["Frac" Frac frac$] + ["Text" Text text$]) + + _ + (fail (text\compose "Cannot anti-quote type: " (name\encode name)))))) + +(def: (anti_quote token) + (-> Code (Meta Code)) + (case token + [_ (#Identifier [def_prefix def_name])] + (if (text\= "" def_prefix) + (do meta_monad + [current_module current_module_name] + (anti_quote_def [current_module def_name])) + (anti_quote_def [def_prefix def_name])) + + (^template [<tag>] + [[meta (<tag> parts)] + (do meta_monad + [=parts (monad\map meta_monad anti_quote parts)] + (wrap [meta (<tag> =parts)]))]) + ([#Form] + [#Tuple]) + + [meta (#Record pairs)] + (do meta_monad + [=pairs (monad\map meta_monad + (: (-> [Code Code] (Meta [Code Code])) + (function (_ [slot value]) + (do meta_monad + [=value (anti_quote value)] + (wrap [slot =value])))) + pairs)] + (wrap [meta (#Record =pairs)])) + + _ + (\ meta_monad return token) + ## TODO: Figure out why this doesn't work: + ## (\ meta_monad wrap token) + )) + +(macro: #export (static tokens) + (case tokens + (^ (list pattern)) + (do meta_monad + [pattern' (anti_quote pattern)] + (wrap (list pattern'))) + + _ + (fail "Wrong syntax for 'static'."))) + +(type: Multi_Level_Case + [Code (List [Code Code])]) + +(def: (case_level^ level) + (-> Code (Meta [Code Code])) + (case level + (^ [_ (#Tuple (list expr binding))]) + (return [expr binding]) + + _ + (return [level (` #1)]) + )) + +(def: (multi_level_case^ levels) + (-> (List Code) (Meta Multi_Level_Case)) + (case levels + #Nil + (fail "Multi-level patterns cannot be empty.") + + (#Cons init extras) + (do meta_monad + [extras' (monad\map meta_monad case_level^ extras)] + (wrap [init extras'])))) + +(def: (multi_level_case$ g!_ [[init_pattern levels] body]) + (-> Code [Multi_Level_Case Code] (List Code)) + (let [inner_pattern_body (list\fold (function (_ [calculation pattern] success) + (let [bind? (case pattern + [_ (#.Identifier _)] + #1 + + _ + #0)] + (` (case (~ calculation) + (~ pattern) + (~ success) + + (~+ (if bind? + (list) + (list g!_ (` #.None)))))))) + (` (#.Some (~ body))) + (: (List [Code Code]) (list\reverse levels)))] + (list init_pattern inner_pattern_body))) + +(macro: #export (^multi tokens) + {#.doc (doc "Multi-level pattern matching." + "Useful in situations where the result of a branch depends on further refinements on the values being matched." + "For example:" + (case (split (size static) uri) + (^multi (#.Some [chunk uri']) [(text\= static chunk) #1]) + (match_uri endpoint? parts' uri') + + _ + (#.Left (format "Static part " (%t static) " does not match URI: " uri))) + + "Short-cuts can be taken when using bit tests." + "The example above can be rewritten as..." + (case (split (size static) uri) + (^multi (#.Some [chunk uri']) (text\= static chunk)) + (match_uri endpoint? parts' uri') + + _ + (#.Left (format "Static part " (%t static) " does not match URI: " uri))))} + (case tokens + (^ (list& [_meta (#Form levels)] body next_branches)) + (do meta_monad + [mlc (multi_level_case^ levels) + #let [initial_bind? (case mlc + [[_ (#.Identifier _)] _] + #1 + + _ + #0)] + expected get_expected_type + g!temp (gensym "temp")] + (let [output (list g!temp + (` ({(#Some (~ g!temp)) + (~ g!temp) + + #None + (case (~ g!temp) + (~+ next_branches))} + ("lux type check" (#.Apply (~ (type_to_code expected)) Maybe) + (case (~ g!temp) + (~+ (multi_level_case$ g!temp [mlc body])) + + (~+ (if initial_bind? + (list) + (list g!temp (` #.None)))))))))] + (wrap output))) + + _ + (fail "Wrong syntax for ^multi"))) + +## TODO: Allow asking the compiler for the name of the definition +## currently being defined. That name can then be fed into +## 'wrong_syntax_error' for easier maintenance of the error_messages. +(def: wrong_syntax_error + (-> Name Text) + (|>> name\encode + (text\compose "Wrong syntax for "))) + +(macro: #export (name_of tokens) + {#.doc (doc "Given an identifier or a tag, gives back a 2 tuple with the prefix and name parts, both as Text." + (name_of #.doc) + "=>" + ["library/lux" "doc"])} + (case tokens + (^template [<tag>] + [(^ (list [_ (<tag> [prefix name])])) + (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))]) + ([#Identifier] [#Tag]) + + _ + (fail (..wrong_syntax_error ["library/lux" "name_of"])))) + +(def: (get_scope_type_vars state) + (Meta (List Nat)) + (case state + {#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} + (#Right state scope_type_vars) + )) + +(def: (list_at idx xs) + (All [a] (-> Nat (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons x xs') + (if ("lux i64 =" 0 idx) + (#Some x) + (list_at (dec idx) xs')))) + +(macro: #export ($ tokens) + {#.doc (doc "Allows you to refer to the type-variables in a polymorphic function's type, by their index." + "In the example below, 0 corresponds to the 'a' variable." + (def: #export (from_list list) + (All [a] (-> (List a) (Row a))) + (list\fold add + (: (Row ($ 0)) + empty) + list)))} + (case tokens + (^ (list [_ (#Nat idx)])) + (do meta_monad + [stvs get_scope_type_vars] + (case (list_at idx (list\reverse stvs)) + (#Some var_id) + (wrap (list (` (#Ex (~ (nat$ var_id)))))) + + #None + (fail (text\compose "Indexed-type does not exist: " (nat\encode idx))))) + + _ + (fail (..wrong_syntax_error (name_of ..$))))) + +(def: #export (is? reference sample) + {#.doc (doc "Tests whether the 2 values are identical (not just 'equal')." + "This one should succeed:" + (let [value +5] + (is? value value)) + + "This one should fail:" + (is? +5 (+ +2 +3)))} + (All [a] (-> a a Bit)) + ("lux is" reference sample)) + +(macro: #export (^@ tokens) + {#.doc (doc "Allows you to simultaneously bind and de-structure a value." + (def: (hash (^@ set [Hash<a> _])) + (list\fold (function (_ elem acc) (+ (\ Hash<a> hash elem) acc)) + 0 + (to_list set))))} + (case tokens + (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] pattern))] body branches)) + (let [g!whole (local_identifier$ name)] + (return (list& g!whole + (` (case (~ g!whole) (~ pattern) (~ body))) + branches))) + + _ + (fail (..wrong_syntax_error (name_of ..^@))))) + +(macro: #export (^|> tokens) + {#.doc (doc "Pipes the value being pattern-matched against prior to binding it to a variable." + (case input + (^|> value [inc (% 10) (max 1)]) + (foo value)))} + (case tokens + (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] [_ (#Tuple steps)]))] body branches)) + (let [g!name (local_identifier$ name)] + (return (list& g!name + (` (let [(~ g!name) (|> (~ g!name) (~+ steps))] + (~ body))) + branches))) + + _ + (fail (..wrong_syntax_error (name_of ..^|>))))) + +(macro: #export (:assume tokens) + {#.doc (doc "Coerces the given expression to the type of whatever is expected." + (: Dinosaur (:assume (list +1 +2 +3))))} + (case tokens + (^ (list expr)) + (do meta_monad + [type get_expected_type] + (wrap (list (` ("lux type as" (~ (type_to_code type)) (~ expr)))))) + + _ + (fail (..wrong_syntax_error (name_of ..:assume))))) + +(def: location + {#.doc "The location of the current expression being analyzed."} + (Meta Location) + (function (_ compiler) + (#Right [compiler (get@ #location compiler)]))) + +(macro: #export (undefined tokens) + {#.doc (doc "Meant to be used as a stand-in for functions with undefined implementations." + "Undefined expressions will type-check against everything, so they make good dummy implementations." + "However, if an undefined expression is ever evaluated, it will raise a runtime error." + (def: (square x) + (-> Int Int) + (undefined)))} + (case tokens + #Nil + (do meta_monad + [location ..location + #let [[module line column] location + location ($_ "lux text concat" (text\encode module) "," (nat\encode line) "," (nat\encode column)) + message ($_ "lux text concat" "Undefined behavior @ " location)]] + (wrap (list (` (..error! (~ (text$ message))))))) + + _ + (fail (..wrong_syntax_error (name_of ..undefined))))) + +(macro: #export (:of tokens) + {#.doc (doc "Generates the type corresponding to a given expression." + "Example #1:" + (let [my_num +123] + (:of my_num)) + "==" + Int + "-------------------" + "Example #2:" + (:of +123) + "==" + Int)} + (case tokens + (^ (list [_ (#Identifier var_name)])) + (do meta_monad + [var_type (find_type var_name)] + (wrap (list (type_to_code var_type)))) + + (^ (list expression)) + (do meta_monad + [g!temp (gensym "g!temp")] + (wrap (list (` (let [(~ g!temp) (~ expression)] + (..:of (~ g!temp))))))) + + _ + (fail (..wrong_syntax_error (name_of ..:of))))) + +(def: (parse_complex_declaration tokens) + (-> (List Code) (Meta [[Text (List Text)] (List Code)])) + (case tokens + (^ (list& [_ (#Form (list& [_ (#Identifier ["" name])] args'))] tokens')) + (do meta_monad + [args (monad\map meta_monad + (function (_ arg') + (case arg' + [_ (#Identifier ["" arg_name])] + (wrap arg_name) + + _ + (fail "Could not parse an argument."))) + args')] + (wrap [[name args] tokens'])) + + _ + (fail "Could not parse a complex declaration.") + )) + +(def: (parse_any tokens) + (-> (List Code) (Meta [Code (List Code)])) + (case tokens + (^ (list& token tokens')) + (return [token tokens']) + + _ + (fail "Could not parse anything.") + )) + +(def: (parse_many tokens) + (-> (List Code) (Meta [(List Code) (List Code)])) + (case tokens + (^ (list& head tail)) + (return [tokens (list)]) + + _ + (fail "Could not parse anything.") + )) + +(def: (parse_end tokens) + (-> (List Code) (Meta Any)) + (case tokens + (^ (list)) + (return []) + + _ + (fail "Expected input Codes to be empty.") + )) + +(def: (parse_anns tokens) + (-> (List Code) (Meta [Code (List Code)])) + (case tokens + (^ (list& [_ (#Record _anns)] tokens')) + (return [(record$ _anns) tokens']) + + _ + (return [(' {}) tokens]) + )) + +(macro: #export (template: tokens) + {#.doc (doc "Define macros in the style of template and ^template." + "For simple macros that do not need any fancy features." + (template: (square x) + (* x x)))} + (do meta_monad + [#let [[export? tokens] (export^ tokens)] + name+args|tokens (parse_complex_declaration tokens) + #let [[[name args] tokens] name+args|tokens] + anns|tokens (parse_anns tokens) + #let [[anns tokens] anns|tokens] + input_templates|tokens (parse_many tokens) + #let [[input_templates tokens] input_templates|tokens] + _ (parse_end tokens) + g!tokens (gensym "tokens") + g!compiler (gensym "compiler") + g!_ (gensym "_") + #let [rep_env (list\map (function (_ arg) + [arg (` ((~' ~) (~ (local_identifier$ arg))))]) + args)] + this_module current_module_name] + (wrap (list (` (macro: (~+ (export export?)) + ((~ (local_identifier$ name)) (~ g!tokens) (~ g!compiler)) + (~ anns) + (case (~ g!tokens) + (^ (list (~+ (list\map local_identifier$ args)))) + (#.Right [(~ g!compiler) + (list (~+ (list\map (function (_ template) + (` (`' (~ (replace_syntax rep_env template))))) + input_templates)))]) + + (~ g!_) + (#.Left (~ (text$ (..wrong_syntax_error [this_module name])))) + ))))) + )) + +(macro: #export (as_is tokens compiler) + (#Right [compiler tokens])) + +(macro: #export (char tokens compiler) + (case tokens + (^multi (^ (list [_ (#Text input)])) + (|> input "lux text size" ("lux i64 =" 1))) + (|> input ("lux text char" 0) + nat$ list + [compiler] #Right) + + _ + (#Left (..wrong_syntax_error (name_of ..char))))) + +(def: target + (Meta Text) + (function (_ compiler) + (#Right [compiler (get@ [#info #target] compiler)]))) + +(def: (resolve_target choice) + (-> Code (Meta Text)) + (case choice + [_ (#Text platform)] + (..return platform) + + [_ (#Identifier identifier)] + (do meta_monad + [identifier (..resolve_global_identifier identifier) + type+value (..find_def_value identifier) + #let [[type value] type+value]] + (case (..flatten_alias type) + (^or (#Primitive "#Text" #Nil) + (#Named ["library/lux" "Text"] (#Primitive "#Text" #Nil))) + (wrap (:as ..Text value)) + + _ + (fail ($_ text\compose + "Invalid target platform (must be a value of type Text): " (name\encode identifier) + " : " (..code\encode (..type_to_code type)))))) + + _ + (fail ($_ text\compose + "Invalid target platform syntax: " (..code\encode choice) + ..\n "Must be either a text literal or an identifier.")))) + +(def: (target_pick target options default) + (-> Text (List [Code Code]) (Maybe Code) (Meta (List Code))) + (case options + #Nil + (case default + #.None + (fail ($_ text\compose "No code for target platform: " target)) + + (#.Some default) + (return (list default))) + + (#Cons [key pick] options') + (do meta_monad + [platform (..resolve_target key)] + (if (text\= target platform) + (return (list pick)) + (target_pick target options' default))))) + +(macro: #export (for tokens) + (do meta_monad + [target ..target] + (case tokens + (^ (list [_ (#Record options)])) + (target_pick target options #.None) + + (^ (list [_ (#Record options)] default)) + (target_pick target options (#.Some default)) + + _ + (fail (..wrong_syntax_error (name_of ..for)))))) + +(template [<name> <type> <output>] + [(def: (<name> xy) + (All [a b] (-> [a b] <type>)) + (let [[x y] xy] + <output>))] + + [left a x] + [right b y]) + +(def: (label_code code) + (-> Code (Meta [(List [Code Code]) Code])) + (case code + (^ [ann (#Form (list [_ (#Identifier ["" "~~"])] expansion))]) + (do meta_monad + [g!expansion (gensym "g!expansion")] + (wrap [(list [g!expansion expansion]) g!expansion])) + + (^template [<tag>] + [[ann (<tag> parts)] + (do meta_monad + [=parts (monad\map meta_monad label_code parts)] + (wrap [(list\fold list\compose (list) (list\map left =parts)) + [ann (<tag> (list\map right =parts))]]))]) + ([#Form] [#Tuple]) + + [ann (#Record kvs)] + (do meta_monad + [=kvs (monad\map meta_monad + (function (_ [key val]) + (do meta_monad + [=key (label_code key) + =val (label_code val) + #let [[key_labels key_labelled] =key + [val_labels val_labelled] =val]] + (wrap [(list\compose key_labels val_labels) [key_labelled val_labelled]]))) + kvs)] + (wrap [(list\fold list\compose (list) (list\map left =kvs)) + [ann (#Record (list\map right =kvs))]])) + + _ + (return [(list) code]))) + +(macro: #export (`` tokens) + (case tokens + (^ (list raw)) + (do meta_monad + [=raw (label_code raw) + #let [[labels labelled] =raw]] + (wrap (list (` (with_expansions [(~+ (|> labels + (list\map (function (_ [label expansion]) (list label expansion))) + list\join))] + (~ labelled)))))) + + _ + (fail (..wrong_syntax_error (name_of ..``))) + )) + +(def: (name$ [module name]) + (-> Name Code) + (` [(~ (text$ module)) (~ (text$ name))])) + +(def: (untemplate_list& last inits) + (-> Code (List Code) Code) + (case inits + #Nil + last + + (#Cons [init inits']) + (` (#.Cons (~ init) (~ (untemplate_list& last inits')))))) + +(def: (untemplate_record g!meta untemplate_pattern fields) + (-> Code (-> Code (Meta Code)) + (-> (List [Code Code]) (Meta Code))) + (do meta_monad + [=fields (monad\map meta_monad + (function (_ [key value]) + (do meta_monad + [=key (untemplate_pattern key) + =value (untemplate_pattern value)] + (wrap (` [(~ =key) (~ =value)])))) + fields)] + (wrap (` [(~ g!meta) (#.Record (~ (untemplate_list =fields)))])))) + +(template [<tag> <name>] + [(def: (<name> g!meta untemplate_pattern elems) + (-> Code (-> Code (Meta Code)) + (-> (List Code) (Meta Code))) + (case (list\reverse elems) + (#Cons [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] + inits) + (do meta_monad + [=inits (monad\map meta_monad untemplate_pattern (list\reverse inits))] + (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list& spliced =inits)))]))) + + _ + (do meta_monad + [=elems (monad\map meta_monad untemplate_pattern elems)] + (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list =elems)))])))))] + + [#.Tuple untemplate_tuple] + [#.Form untemplate_form] + ) + +(def: (untemplate_pattern pattern) + (-> Code (Meta Code)) + (do meta_monad + [g!meta (gensym "g!meta")] + (case pattern + (^template [<tag> <gen>] + [[_ (<tag> value)] + (wrap (` [(~ g!meta) (<tag> (~ (<gen> value)))]))]) + ([#.Bit bit$] + [#.Nat nat$] + [#.Int int$] + [#.Rev rev$] + [#.Frac frac$] + [#.Text text$] + [#.Tag name$] + [#.Identifier name$]) + + [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))] + (return unquoted) + + [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] + (fail "Cannot use (~+) inside of ^code unless it is the last element in a form or a tuple.") + + (^template [<tag> <untemplate>] + [[_ (<tag> elems)] + (<untemplate> g!meta untemplate_pattern elems)]) + ([#.Tuple ..untemplate_tuple] + [#.Form ..untemplate_form]) + + [_ (#Record fields)] + (..untemplate_record g!meta untemplate_pattern fields) + ))) + +(macro: #export (^code tokens) + (case tokens + (^ (list& [_meta (#Form (list template))] body branches)) + (do meta_monad + [pattern (untemplate_pattern template)] + (wrap (list& pattern body branches))) + + (^ (list template)) + (do meta_monad + [pattern (untemplate_pattern template)] + (wrap (list pattern))) + + _ + (fail (..wrong_syntax_error (name_of ..^code))))) + +(template [<zero> <one>] + [(def: #export <zero> #0) + (def: #export <one> #1)] + + [false true] + [no yes] + [off on] + ) + +(macro: #export (:let tokens) + (case tokens + (^ (list [_ (#Tuple bindings)] bodyT)) + (if (multiple? 2 (list\size bindings)) + (return (list (` (..with_expansions [(~+ (|> bindings + ..as_pairs + (list\map (function (_ [localT valueT]) + (list localT (` (..as_is (~ valueT)))))) + (list\fold list\compose (list))))] + (~ bodyT))))) + (..fail ":let requires an even number of parts")) + + _ + (..fail (..wrong_syntax_error (name_of ..:let))))) + +(macro: #export (try tokens) + {#.doc (doc (case (try (risky_computation input)) + (#.Right success) + (do_something success) + + (#.Left error) + (recover_from_failure error)))} + (case tokens + (^ (list expression)) + (do meta_monad + [g!_ (gensym "g!_")] + (wrap (list (` ("lux try" + (.function ((~ g!_) (~ g!_)) + (~ expression))))))) + + _ + (..fail (..wrong_syntax_error (name_of ..try))))) |