aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/library/lux.lux
diff options
context:
space:
mode:
authorEduardo Julian2021-07-14 13:59:02 -0400
committerEduardo Julian2021-07-14 13:59:02 -0400
commitd6c48ae6a8b58f5974133170863a31c70f0123d1 (patch)
tree008eb88328009e2f3f07002f35c0378a8a137ed0 /stdlib/source/library/lux.lux
parent2431e767a09894c2f685911ba7f1ba0b7de2a165 (diff)
Normalized the hierarchy of the standard library modules.
Diffstat (limited to 'stdlib/source/library/lux.lux')
-rw-r--r--stdlib/source/library/lux.lux5958
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..3a7fa442b
--- /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 [..prelude_module "Any"]
+ (8 #0 (0 #0) (4 #0 1))))
+ [dummy_location
+ (9 #1 (0 #1 [[dummy_location (7 #0 [..prelude_module "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 [..prelude_module "Nothing"]
+ (7 #0 (0 #0) (4 #0 1))))
+ [dummy_location
+ (9 #1 (0 #1 [[dummy_location (7 #0 [..prelude_module "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 [..prelude_module "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 [..prelude_module "type-args"])]
+ [dummy_location (9 #0 (0 #1 [dummy_location (5 #0 "a")] (0 #0)))]]
+ (0 #1 [[dummy_location (7 #0 [..prelude_module "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 [..prelude_module "Bit"]
+ (0 #0 "#Bit" #Nil)))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "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 [..prelude_module "I64"]
+ (7 #0 (0 #0)
+ (0 #0 "#I64" (#Cons (4 #0 1) #Nil)))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "64-bit integers without any semantics.")]]
+ #Nil))]
+ #1)
+
+("lux def" Nat
+ ("lux type check type"
+ (9 #1 [..prelude_module "Nat"]
+ (0 #0 "#I64" (#Cons (0 #0 "#Nat" #Nil) #Nil))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "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 [..prelude_module "Int"]
+ (0 #0 "#I64" (#Cons (0 #0 "#Int" #Nil) #Nil))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "Your standard, run-of-the-mill integer numbers.")]]
+ #Nil))]
+ #1)
+
+("lux def" Rev
+ ("lux type check type"
+ (9 #1 [..prelude_module "Rev"]
+ (0 #0 "#I64" (#Cons (0 #0 "#Rev" #Nil) #Nil))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "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 [..prelude_module "Frac"]
+ (0 #0 "#Frac" #Nil)))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "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 [..prelude_module "Text"]
+ (0 #0 "#Text" #Nil)))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "Your standard, run-of-the-mill string values.")]]
+ #Nil))]
+ #1)
+
+("lux def" Name
+ ("lux type check type"
+ (9 #1 [..prelude_module "Name"]
+ (2 #0 Text Text)))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "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 [..prelude_module "Maybe"]
+ (7 #0 #Nil
+ (1 #0 ## "lux.None"
+ Any
+ ## "lux.Some"
+ (4 #0 1))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "type-args"])]
+ [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "a")] #Nil))]]
+ (#Cons [[dummy_location (7 #0 [..prelude_module "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 [..prelude_module "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 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "This type represents the data-structures that are used to specify types themselves.")]]
+ (#Cons [[dummy_location (7 #0 [..prelude_module "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 [..prelude_module "Location"]
+ (#Product Text (#Product Nat Nat)))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "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 [..prelude_module "Ann"]
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#Product (#Parameter 3)
+ (#Parameter 1)))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "The type of things that can be annotated with meta-data of arbitrary types.")]]
+ (#Cons [[dummy_location (7 #0 [..prelude_module "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 [..prelude_module "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 [..prelude_module "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 [..prelude_module "Code"]
+ ({w
+ (#Apply (#Apply w Code') w)}
+ ("lux type check type" (#Apply Location Ann))))
+ [dummy_location
+ (#Record (#Cons [[dummy_location (#Tag [..prelude_module "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 [..prelude_module "Definition"]
+ (#Product Bit (#Product Type (#Product Code Any)))))
+ (record$ (#Cons [(tag$ [..prelude_module "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 [..prelude_module "Alias"]
+ Name))
+ (record$ #Nil)
+ #1)
+
+## (type: Global
+## (#Alias Alias)
+## (#Definition Definition))
+("lux def type tagged" Global
+ (#Named [..prelude_module "Global"]
+ (#Sum Alias
+ Definition))
+ (record$ (#Cons [(tag$ [..prelude_module "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 [..prelude_module "Bindings"]
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#Product ## "lux.counter"
+ Nat
+ ## "lux.mappings"
+ (#Apply (#Product (#Parameter 3)
+ (#Parameter 1))
+ List)))))
+ (record$ (#Cons [(tag$ [..prelude_module "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 [..prelude_module "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 [..prelude_module "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 [..prelude_module "Either"]
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#Sum ## "lux.Left"
+ (#Parameter 3)
+ ## "lux.Right"
+ (#Parameter 1)))))
+ (record$ (#Cons [(tag$ [..prelude_module "type-args"])
+ (tuple$ (#Cons (text$ "l") (#Cons (text$ "r") #Nil)))]
+ (#Cons [(tag$ [..prelude_module "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 [..prelude_module "Source"]
+ (#Product Location (#Product Nat Text))))
+ (record$ #Nil)
+ #1)
+
+## (type: Module_State
+## #Active
+## #Compiled
+## #Cached)
+("lux def type tagged" Module_State
+ (#Named [..prelude_module "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 [..prelude_module "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$ [..prelude_module "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 [..prelude_module "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 [..prelude_module "Mode"]
+ (#Sum ## Build
+ Any
+ (#Sum ## Eval
+ Any
+ ## Interpreter
+ Any)))
+ (record$ (#Cons [(tag$ [..prelude_module "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 [..prelude_module "Info"]
+ (#Product
+ ## target
+ Text
+ (#Product
+ ## version
+ Text
+ ## mode
+ Mode)))
+ (record$ (#Cons [(tag$ [..prelude_module "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 [..prelude_module "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$ [..prelude_module "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 [..prelude_module "Meta"]
+ (#UnivQ #Nil
+ (#Function Lux
+ (#Apply (#Product Lux (#Parameter 1))
+ (#Apply Text Either))))))
+ (record$ (#Cons [(tag$ [..prelude_module "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$ [..prelude_module "type-args"])
+ (tuple$ (#Cons (text$ "a") #Nil))]
+ #Nil)))
+ #1)
+
+## (type: Macro'
+## (-> (List Code) (Meta (List Code))))
+("lux def" Macro'
+ ("lux type check type"
+ (#Named [..prelude_module "Macro'"]
+ (#Function Code_List (#Apply Code_List Meta))))
+ (record$ #Nil)
+ #1)
+
+## (type: Macro
+## (primitive "#Macro"))
+("lux def" Macro
+ ("lux type check type"
+ (#Named [..prelude_module "Macro"]
+ (#Primitive "#Macro" #Nil)))
+ (record$ (#Cons [(tag$ [..prelude_module "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 [..prelude_module "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 [..prelude_module "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 [..prelude_module "Tag"] (tuple$ (#Cons (text$ ..prelude_module) (#Cons (text$ tag) #Nil))))
+ (#Cons [(meta_code [..prelude_module "Bit"] (bit$ #1))
+ #Nil])]))))
+ (record$ #Nil)
+ #0)
+
+("lux def" doc_meta
+ ("lux type check" (#Function Text (#Product Code Code))
+ (function'' [doc] [(tag$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "record$"])
+ (#Cons (tag$ [..prelude_module "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$ [..prelude_module "record$"])
+ (#Cons (tag$ [..prelude_module "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$ [..prelude_module "record$"])
+ (#Cons meta_data
+ #Nil)))
+ #1)
+ #Nil))
+
+ _
+ (fail "Wrong syntax for macro:'")}
+ tokens)))
+ (record$ #.Nil)
+ #0)
+
+(macro:' #export (comment tokens)
+ (#Cons [(tag$ [..prelude_module "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$ [..prelude_module "$'"])
+ (#Cons (form$ (#Cons (tag$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "UnivQ"])
+ (#Cons (tag$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "ExQ"])
+ (#Cons (tag$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "Function"]) (#Cons i (#Cons o #Nil))))))
+ output
+ inputs)
+ #Nil))
+
+ _
+ (fail "Wrong syntax for ->")}
+ (list\reverse tokens)))
+
+(macro:' #export (list xs)
+ (#Cons [(tag$ [..prelude_module "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$ [..prelude_module "Cons"])
+ (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])]))
+ #Nil))))
+ (tag$ [..prelude_module "Nil"])
+ (list\reverse xs))
+ #Nil)))
+
+(macro:' #export (list& xs)
+ (#Cons [(tag$ [..prelude_module "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$ [..prelude_module "Cons"])
+ (tuple$ (list head tail)))))
+ last
+ init)))
+
+ _
+ (fail "Wrong syntax for list&")}
+ (list\reverse xs)))
+
+(macro:' #export (& tokens)
+ (#Cons [(tag$ [..prelude_module "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$ [..prelude_module "Any"])))
+
+ (#Cons last prevs)
+ (return (list (list\fold (function'' [left right] (form$ (list (tag$ [..prelude_module "Product"]) left right)))
+ last
+ prevs)))}
+ (list\reverse tokens)))
+
+(macro:' #export (| tokens)
+ (#Cons [(tag$ [..prelude_module "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$ [..prelude_module "Nothing"])))
+
+ (#Cons last prevs)
+ (return (list (list\fold (function'' [left right] (form$ (list (tag$ [..prelude_module "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$ [..prelude_module "function'"])
+ name
+ (tuple$ args)
+ body))))
+ (form$ (#Cons (identifier$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "function'"])
+ name
+ (tuple$ args)
+ body))))
+ (form$ (#Cons (identifier$ [..prelude_module "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$ [..prelude_module "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 [..prelude_module "Nil"]))
+
+ (#Cons [token tokens'])
+ (_ann (#Form (list (_ann (#Tag [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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 [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "wrap"]) g!wrap] [(tag$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "Apply"])
+ (identifier$ [..prelude_module "Code"])
+ (identifier$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "Cons"])
+ (tuple$ (list lastO (tag$ [..prelude_module "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$ ..prelude_module)
+ (identifier$ [..prelude_module "list\compose"])))]
+ (wrap (form$ (list g!in-module (as_code_list spliced) rightO))))
+
+ _
+ (do meta_monad
+ [leftO (untemplate leftI)]
+ (wrap (form$ (list (tag$ [..prelude_module "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$ [..prelude_module "Text"]) (text$ value)))))
+
+(def:''' (untemplate replace? subst token)
+ #Nil
+ (-> Bit Text Code ($' Meta Code))
+ ({[_ [_ (#Bit value)]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Bit"]) (bit$ value)))))
+
+ [_ [_ (#Nat value)]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Nat"]) (nat$ value)))))
+
+ [_ [_ (#Int value)]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Int"]) (int$ value)))))
+
+ [_ [_ (#Rev value)]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Rev"]) (rev$ value)))))
+
+ [_ [_ (#Frac value)]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Frac"]) (frac$ value)))))
+
+ [_ [_ (#Text value)]]
+ (return (untemplate_text value))
+
+ [#0 [_ (#Tag [module name])]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Tag"]) (tuple$ (list (text$ module) (text$ name)))))))
+
+ [#1 [_ (#Tag [module name])]]
+ (let' [module' ({""
+ subst
+
+ _
+ module}
+ module)]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "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$ [..prelude_module "Identifier"]) (tuple$ (list (text$ module) (text$ name))))))))
+
+ [#0 [_ (#Identifier [module name])]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Identifier"]) (tuple$ (list (text$ module) (text$ name)))))))
+
+ [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))]]
+ (return (form$ (list (text$ "lux type check")
+ (identifier$ [..prelude_module "Code"])
+ unquoted)))
+
+ [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~!"])] (#Cons [dependent #Nil])]))]]
+ (do meta_monad
+ [independent (untemplate replace? subst dependent)]
+ (wrap (wrap_meta (form$ (list (tag$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "Record"]) (untemplate_list =fields))))))}
+ [replace? token]))
+
+(macro:' #export (primitive tokens)
+ (list [(tag$ [..prelude_module "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$ [..prelude_module "Primitive"]) (text$ class_name) (tag$ [..prelude_module "Nil"])))))
+
+ (#Cons [_ (#Text class_name)] (#Cons [_ (#Tuple params)] #Nil))
+ (return (list (form$ (list (tag$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "Code"])
+ =template)))))
+
+ _
+ (fail "Wrong syntax for `")}
+ tokens))
+
+(macro:' #export (`' tokens)
+ (list [(tag$ [..prelude_module "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$ [..prelude_module "Code"]) =template)))))
+
+ _
+ (fail "Wrong syntax for `")}
+ tokens))
+
+(macro:' #export (' tokens)
+ (list [(tag$ [..prelude_module "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$ [..prelude_module "Code"]) =template)))))
+
+ _
+ (fail "Wrong syntax for '")}
+ tokens))
+
+(macro:' #export (|> tokens)
+ (list [(tag$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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 [..prelude_module "Bit"] (bit$ value))
+
+ [_ (#Nat value)]
+ (meta_code [..prelude_module "Nat"] (nat$ value))
+
+ [_ (#Int value)]
+ (meta_code [..prelude_module "Int"] (int$ value))
+
+ [_ (#Rev value)]
+ (meta_code [..prelude_module "Rev"] (rev$ value))
+
+ [_ (#Frac value)]
+ (meta_code [..prelude_module "Frac"] (frac$ value))
+
+ [_ (#Text value)]
+ (meta_code [..prelude_module "Text"] (text$ value))
+
+ [_ (#Tag [prefix name])]
+ (meta_code [..prelude_module "Tag"] (` [(~ (text$ prefix)) (~ (text$ name))]))
+
+ (^or [_ (#Form _)] [_ (#Identifier _)])
+ code
+
+ [_ (#Tuple xs)]
+ (|> xs
+ (list\map process_def_meta_value)
+ untemplate_list
+ (meta_code [..prelude_module "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 [..prelude_module "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 [..prelude_module "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$ [..prelude_module "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$ [..prelude_module "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)
+ "=>"
+ [..prelude_module "doc"])}
+ (case tokens
+ (^template [<tag>]
+ [(^ (list [_ (<tag> [prefix name])]))
+ (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))])
+ ([#Identifier] [#Tag])
+
+ _
+ (fail (..wrong_syntax_error [..prelude_module "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)))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-03 05:18:56 +0000