From d6c48ae6a8b58f5974133170863a31c70f0123d1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 14 Jul 2021 13:59:02 -0400 Subject: Normalized the hierarchy of the standard library modules. --- stdlib/source/lux.lux | 5953 ------------------------------------------------- 1 file changed, 5953 deletions(-) delete mode 100644 stdlib/source/lux.lux (limited to 'stdlib/source/lux.lux') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux deleted file mode 100644 index da491b2c8..000000000 --- a/stdlib/source/lux.lux +++ /dev/null @@ -1,5953 +0,0 @@ -("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) - -## (type: Any -## (Ex [a] a)) -("lux def" Any - ("lux type check type" - (9 #1 ["lux" "Any"] - (8 #0 (0 #0) (4 #0 1)))) - [dummy_location - (9 #1 (0 #1 [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 ("lux text concat" - ("lux text concat" "The type of things whose type is irrelevant." __paragraph) - "It can be used to write functions or data-structures that can take, or return, anything."))]] - (0 #0)))] - #1) - -## (type: Nothing -## (All [a] a)) -("lux def" Nothing - ("lux type check type" - (9 #1 ["lux" "Nothing"] - (7 #0 (0 #0) (4 #0 1)))) - [dummy_location - (9 #1 (0 #1 [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 ("lux text concat" - ("lux text concat" "The type of things whose type is undefined." __paragraph) - "Useful for expressions that cause errors or other 'extraordinary' conditions."))]] - (0 #0)))] - #1) - -## (type: (List a) -## #Nil -## (#Cons a (List a))) -("lux def type tagged" List - (9 #1 ["lux" "List"] - (7 #0 (0 #0) - (1 #0 ## "lux.Nil" - Any - ## "lux.Cons" - (2 #0 (4 #0 1) - (9 #0 (4 #0 1) (4 #0 0)))))) - [dummy_location - (9 #1 (0 #1 [[dummy_location (7 #0 ["lux" "type-args"])] - [dummy_location (9 #0 (0 #1 [dummy_location (5 #0 "a")] (0 #0)))]] - (0 #1 [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 "A potentially empty list of values.")]] - (0 #0))))] - ["Nil" "Cons"] - #1) - -("lux def" Bit - ("lux type check type" - (9 #1 ["lux" "Bit"] - (0 #0 "#Bit" #Nil))) - [dummy_location - (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 "Your standard, run-of-the-mill boolean values (as bits).")]] - #Nil))] - #1) - -("lux def" I64 - ("lux type check type" - (9 #1 ["lux" "I64"] - (7 #0 (0 #0) - (0 #0 "#I64" (#Cons (4 #0 1) #Nil))))) - [dummy_location - (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 "64-bit integers without any semantics.")]] - #Nil))] - #1) - -("lux def" Nat - ("lux type check type" - (9 #1 ["lux" "Nat"] - (0 #0 "#I64" (#Cons (0 #0 "#Nat" #Nil) #Nil)))) - [dummy_location - (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 ("lux text concat" - ("lux text concat" "Natural numbers (unsigned integers)." __paragraph) - "They start at zero (0) and extend in the positive direction."))]] - #Nil))] - #1) - -("lux def" Int - ("lux type check type" - (9 #1 ["lux" "Int"] - (0 #0 "#I64" (#Cons (0 #0 "#Int" #Nil) #Nil)))) - [dummy_location - (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 "Your standard, run-of-the-mill integer numbers.")]] - #Nil))] - #1) - -("lux def" Rev - ("lux type check type" - (9 #1 ["lux" "Rev"] - (0 #0 "#I64" (#Cons (0 #0 "#Rev" #Nil) #Nil)))) - [dummy_location - (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 ("lux text concat" - ("lux text concat" "Fractional numbers that live in the interval [0,1)." __paragraph) - "Useful for probability, and other domains that work within that interval."))]] - #Nil))] - #1) - -("lux def" Frac - ("lux type check type" - (9 #1 ["lux" "Frac"] - (0 #0 "#Frac" #Nil))) - [dummy_location - (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 "Your standard, run-of-the-mill floating-point (fractional) numbers.")]] - #Nil))] - #1) - -("lux def" Text - ("lux type check type" - (9 #1 ["lux" "Text"] - (0 #0 "#Text" #Nil))) - [dummy_location - (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 "Your standard, run-of-the-mill string values.")]] - #Nil))] - #1) - -("lux def" Name - ("lux type check type" - (9 #1 ["lux" "Name"] - (2 #0 Text Text))) - [dummy_location - (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 "A name. It is used as part of Lux syntax to represent identifiers and tags.")]] - #Nil))] - #1) - -## (type: (Maybe a) -## #None -## (#Some a)) -("lux def type tagged" Maybe - (9 #1 ["lux" "Maybe"] - (7 #0 #Nil - (1 #0 ## "lux.None" - Any - ## "lux.Some" - (4 #0 1)))) - [dummy_location - (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "type-args"])] - [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "a")] #Nil))]] - (#Cons [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 "A potentially missing value.")]] - #Nil)))] - ["None" "Some"] - #1) - -## (type: #rec Type -## (#Primitive Text (List Type)) -## (#Sum Type Type) -## (#Product Type Type) -## (#Function Type Type) -## (#Parameter Nat) -## (#Var Nat) -## (#Ex Nat) -## (#UnivQ (List Type) Type) -## (#ExQ (List Type) Type) -## (#Apply Type Type) -## (#Named Name Type) -## ) -("lux def type tagged" Type - (9 #1 ["lux" "Type"] - ({Type - ({Type_List - ({Type_Pair - (9 #0 Nothing - (7 #0 #Nil - (1 #0 ## "lux.Primitive" - (2 #0 Text Type_List) - (1 #0 ## "lux.Sum" - Type_Pair - (1 #0 ## "lux.Product" - Type_Pair - (1 #0 ## "lux.Function" - Type_Pair - (1 #0 ## "lux.Parameter" - Nat - (1 #0 ## "lux.Var" - Nat - (1 #0 ## "lux.Ex" - Nat - (1 #0 ## "lux.UnivQ" - (2 #0 Type_List Type) - (1 #0 ## "lux.ExQ" - (2 #0 Type_List Type) - (1 #0 ## "lux.Apply" - Type_Pair - ## "lux.Named" - (2 #0 Name Type)))))))))))))} - ("lux type check type" (2 #0 Type Type)))} - ("lux type check type" (9 #0 Type List)))} - ("lux type check type" (9 #0 (4 #0 1) (4 #0 0))))) - [dummy_location - (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 "This type represents the data-structures that are used to specify types themselves.")]] - (#Cons [[dummy_location (7 #0 ["lux" "type-rec?"])] - [dummy_location (0 #0 #1)]] - #Nil)))] - ["Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named"] - #1) - -## (type: Location -## {#module Text -## #line Nat -## #column Nat}) -("lux def type tagged" Location - (#Named ["lux" "Location"] - (#Product Text (#Product Nat Nat))) - [dummy_location - (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 "Locations are for specifying the location of Code nodes in Lux files during compilation.")]] - #Nil))] - ["module" "line" "column"] - #1) - -## (type: (Ann m v) -## {#meta m -## #datum v}) -("lux def type tagged" Ann - (#Named ["lux" "Ann"] - (#UnivQ #Nil - (#UnivQ #Nil - (#Product (#Parameter 3) - (#Parameter 1))))) - [dummy_location - (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])] - [dummy_location (5 #0 "The type of things that can be annotated with meta-data of arbitrary types.")]] - (#Cons [[dummy_location (7 #0 ["lux" "type-args"])] - [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "m")] (#Cons [dummy_location (5 #0 "v")] #Nil)))]] - #Nil)))] - ["meta" "datum"] - #1) - -## (type: (Code' w) -## (#Bit Bit) -## (#Nat Nat) -## (#Int Int) -## (#Rev Rev) -## (#Frac Frac) -## (#Text Text) -## (#Identifier Name) -## (#Tag Name) -## (#Form (List (w (Code' w)))) -## (#Tuple (List (w (Code' w)))) -## (#Record (List [(w (Code' w)) (w (Code' w))]))) -("lux def type tagged" Code' - (#Named ["lux" "Code'"] - ({Code - ({Code_List - (#UnivQ #Nil - (#Sum ## "lux.Bit" - Bit - (#Sum ## "lux.Nat" - Nat - (#Sum ## "lux.Int" - Int - (#Sum ## "lux.Rev" - Rev - (#Sum ## "lux.Frac" - Frac - (#Sum ## "lux.Text" - Text - (#Sum ## "lux.Identifier" - Name - (#Sum ## "lux.Tag" - Name - (#Sum ## "lux.Form" - Code_List - (#Sum ## "lux.Tuple" - Code_List - ## "lux.Record" - (#Apply (#Product Code Code) List) - )))))))))) - )} - ("lux type check type" (#Apply Code List)))} - ("lux type check type" (#Apply (#Apply (#Parameter 1) - (#Parameter 0)) - (#Parameter 1))))) - [dummy_location - (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "type-args"])] - [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "w")] #Nil))]] - #Nil))] - ["Bit" "Nat" "Int" "Rev" "Frac" "Text" "Identifier" "Tag" "Form" "Tuple" "Record"] - #1) - -## (type: Code -## (Ann Location (Code' (Ann Location)))) -("lux def" Code - (#Named ["lux" "Code"] - ({w - (#Apply (#Apply w Code') w)} - ("lux type check type" (#Apply Location Ann)))) - [dummy_location - (#Record (#Cons [[dummy_location (#Tag ["lux" "doc"])] - [dummy_location (#Text "The type of Code nodes for Lux syntax.")]] - #Nil))] - #1) - -("lux def" _ann - ("lux type check" - (#Function (#Apply (#Apply Location Ann) - Code') - Code) - ([_ data] - [dummy_location data])) - [dummy_location (#Record #Nil)] - #0) - -("lux def" bit$ - ("lux type check" (#Function Bit Code) - ([_ value] (_ann (#Bit value)))) - [dummy_location (#Record #Nil)] - #0) - -("lux def" nat$ - ("lux type check" (#Function Nat Code) - ([_ value] (_ann (#Nat value)))) - [dummy_location (#Record #Nil)] - #0) - -("lux def" int$ - ("lux type check" (#Function Int Code) - ([_ value] (_ann (#Int value)))) - [dummy_location (#Record #Nil)] - #0) - -("lux def" rev$ - ("lux type check" (#Function Rev Code) - ([_ value] (_ann (#Rev value)))) - [dummy_location (#Record #Nil)] - #0) - -("lux def" frac$ - ("lux type check" (#Function Frac Code) - ([_ value] (_ann (#Frac value)))) - [dummy_location (#Record #Nil)] - #0) - -("lux def" text$ - ("lux type check" (#Function Text Code) - ([_ text] (_ann (#Text text)))) - [dummy_location (#Record #Nil)] - #0) - -("lux def" identifier$ - ("lux type check" (#Function Name Code) - ([_ name] (_ann (#Identifier name)))) - [dummy_location (#Record #Nil)] - #0) - -("lux def" local_identifier$ - ("lux type check" (#Function Text Code) - ([_ name] (_ann (#Identifier ["" name])))) - [dummy_location (#Record #Nil)] - #0) - -("lux def" tag$ - ("lux type check" (#Function Name Code) - ([_ name] (_ann (#Tag name)))) - [dummy_location (#Record #Nil)] - #0) - -("lux def" local_tag$ - ("lux type check" (#Function Text Code) - ([_ name] (_ann (#Tag ["" name])))) - [dummy_location (#Record #Nil)] - #0) - -("lux def" form$ - ("lux type check" (#Function (#Apply Code List) Code) - ([_ tokens] (_ann (#Form tokens)))) - [dummy_location (#Record #Nil)] - #0) - -("lux def" tuple$ - ("lux type check" (#Function (#Apply Code List) Code) - ([_ tokens] (_ann (#Tuple tokens)))) - [dummy_location (#Record #Nil)] - #0) - -("lux def" record$ - ("lux type check" (#Function (#Apply (#Product Code Code) List) Code) - ([_ tokens] (_ann (#Record tokens)))) - [dummy_location (#Record #Nil)] - #0) - -## (type: Definition -## [Bit Type Code Any]) -("lux def" Definition - ("lux type check type" - (#Named ["lux" "Definition"] - (#Product Bit (#Product Type (#Product Code Any))))) - (record$ (#Cons [(tag$ ["lux" "doc"]) - (text$ "Represents all the data associated with a definition: its type, its annotations, and its value.")] - #Nil)) - #1) - -## (type: Alias -## Name) -("lux def" Alias - ("lux type check type" - (#Named ["lux" "Alias"] - Name)) - (record$ #Nil) - #1) - -## (type: Global -## (#Alias Alias) -## (#Definition Definition)) -("lux def type tagged" Global - (#Named ["lux" "Global"] - (#Sum Alias - Definition)) - (record$ (#Cons [(tag$ ["lux" "doc"]) - (text$ "Represents all the data associated with a global constant.")] - #Nil)) - ["Alias" "Definition"] - #1) - -## (type: (Bindings k v) -## {#counter Nat -## #mappings (List [k v])}) -("lux def type tagged" Bindings - (#Named ["lux" "Bindings"] - (#UnivQ #Nil - (#UnivQ #Nil - (#Product ## "lux.counter" - Nat - ## "lux.mappings" - (#Apply (#Product (#Parameter 3) - (#Parameter 1)) - List))))) - (record$ (#Cons [(tag$ ["lux" "type-args"]) - (tuple$ (#Cons (text$ "k") (#Cons (text$ "v") #Nil)))] - #Nil)) - ["counter" "mappings"] - #1) - -## (type: #export Ref -## (#Local Nat) -## (#Captured Nat)) -("lux def type tagged" Ref - (#Named ["lux" "Ref"] - (#Sum ## Local - Nat - ## Captured - Nat)) - (record$ #Nil) - ["Local" "Captured"] - #1) - -## (type: Scope -## {#name (List Text) -## #inner Nat -## #locals (Bindings Text [Type Nat]) -## #captured (Bindings Text [Type Ref])}) -("lux def type tagged" Scope - (#Named ["lux" "Scope"] - (#Product ## name - (#Apply Text List) - (#Product ## inner - Nat - (#Product ## locals - (#Apply (#Product Type Nat) (#Apply Text Bindings)) - ## captured - (#Apply (#Product Type Ref) (#Apply Text Bindings)))))) - (record$ #Nil) - ["name" "inner" "locals" "captured"] - #1) - -("lux def" Code_List - ("lux type check type" - (#Apply Code List)) - (record$ #Nil) - #0) - -## (type: (Either l r) -## (#Left l) -## (#Right r)) -("lux def type tagged" Either - (#Named ["lux" "Either"] - (#UnivQ #Nil - (#UnivQ #Nil - (#Sum ## "lux.Left" - (#Parameter 3) - ## "lux.Right" - (#Parameter 1))))) - (record$ (#Cons [(tag$ ["lux" "type-args"]) - (tuple$ (#Cons (text$ "l") (#Cons (text$ "r") #Nil)))] - (#Cons [(tag$ ["lux" "doc"]) - (text$ "A choice between two values of different types.")] - #Nil))) - ["Left" "Right"] - #1) - -## (type: Source -## [Location Nat Text]) -("lux def" Source - ("lux type check type" - (#Named ["lux" "Source"] - (#Product Location (#Product Nat Text)))) - (record$ #Nil) - #1) - -## (type: Module_State -## #Active -## #Compiled -## #Cached) -("lux def type tagged" Module_State - (#Named ["lux" "Module_State"] - (#Sum - ## #Active - Any - (#Sum - ## #Compiled - Any - ## #Cached - Any))) - (record$ #Nil) - ["Active" "Compiled" "Cached"] - #1) - -## (type: Module -## {#module_hash Nat -## #module_aliases (List [Text Text]) -## #definitions (List [Text Global]) -## #imports (List Text) -## #tags (List [Text [Nat (List Name) Bit Type]]) -## #types (List [Text [(List Name) Bit Type]]) -## #module_annotations (Maybe Code) -## #module_state Module_State}) -("lux def type tagged" Module - (#Named ["lux" "Module"] - (#Product ## "lux.module_hash" - Nat - (#Product ## "lux.module_aliases" - (#Apply (#Product Text Text) List) - (#Product ## "lux.definitions" - (#Apply (#Product Text Global) List) - (#Product ## "lux.imports" - (#Apply Text List) - (#Product ## "lux.tags" - (#Apply (#Product Text - (#Product Nat - (#Product (#Apply Name List) - (#Product Bit - Type)))) - List) - (#Product ## "lux.types" - (#Apply (#Product Text - (#Product (#Apply Name List) - (#Product Bit - Type))) - List) - (#Product ## "lux.module_annotations" - (#Apply Code Maybe) - Module_State)) - )))))) - (record$ (#Cons [(tag$ ["lux" "doc"]) - (text$ "All the information contained within a Lux module.")] - #Nil)) - ["module_hash" "module_aliases" "definitions" "imports" "tags" "types" "module_annotations" "module_state"] - #1) - -## (type: Type_Context -## {#ex_counter Nat -## #var_counter Nat -## #var_bindings (List [Nat (Maybe Type)])}) -("lux def type tagged" Type_Context - (#Named ["lux" "Type_Context"] - (#Product ## ex_counter - Nat - (#Product ## var_counter - Nat - ## var_bindings - (#Apply (#Product Nat (#Apply Type Maybe)) - List)))) - (record$ #Nil) - ["ex_counter" "var_counter" "var_bindings"] - #1) - -## (type: Mode -## #Build -## #Eval -## #Interpreter) -("lux def type tagged" Mode - (#Named ["lux" "Mode"] - (#Sum ## Build - Any - (#Sum ## Eval - Any - ## Interpreter - Any))) - (record$ (#Cons [(tag$ ["lux" "doc"]) - (text$ "A sign that shows the conditions under which the compiler is running.")] - #Nil)) - ["Build" "Eval" "Interpreter"] - #1) - -## (type: Info -## {#target Text -## #version Text -## #mode Mode}) -("lux def type tagged" Info - (#Named ["lux" "Info"] - (#Product - ## target - Text - (#Product - ## version - Text - ## mode - Mode))) - (record$ (#Cons [(tag$ ["lux" "doc"]) - (text$ "Information about the current version and type of compiler that is running.")] - #Nil)) - ["target" "version" "mode"] - #1) - -## (type: Lux -## {#info Info -## #source Source -## #location Location -## #current_module (Maybe Text) -## #modules (List [Text Module]) -## #scopes (List Scope) -## #type_context Type_Context -## #expected (Maybe Type) -## #seed Nat -## #scope_type_vars (List Nat) -## #extensions Any -## #host Any}) -("lux def type tagged" Lux - (#Named ["lux" "Lux"] - (#Product ## "lux.info" - Info - (#Product ## "lux.source" - Source - (#Product ## "lux.location" - Location - (#Product ## "lux.current_module" - (#Apply Text Maybe) - (#Product ## "lux.modules" - (#Apply (#Product Text Module) List) - (#Product ## "lux.scopes" - (#Apply Scope List) - (#Product ## "lux.type_context" - Type_Context - (#Product ## "lux.expected" - (#Apply Type Maybe) - (#Product ## "lux.seed" - Nat - (#Product ## scope_type_vars - (#Apply Nat List) - (#Product ## extensions - Any - ## "lux.host" - Any)))))))))))) - (record$ (#Cons [(tag$ ["lux" "doc"]) - (text$ ("lux text concat" - ("lux text concat" "Represents the state of the Lux compiler during a run." __paragraph) - ("lux text concat" - ("lux text concat" "It is provided to macros during their invocation, so they can access compiler data." __paragraph) - "Caveat emptor: Avoid fiddling with it, unless you know what you're doing.")))] - #Nil)) - ["info" "source" "location" "current_module" "modules" "scopes" "type_context" "expected" "seed" "scope_type_vars" "extensions" "host"] - #1) - -## (type: (Meta a) -## (-> Lux (Either Text [Lux a]))) -("lux def" Meta - ("lux type check type" - (#Named ["lux" "Meta"] - (#UnivQ #Nil - (#Function Lux - (#Apply (#Product Lux (#Parameter 1)) - (#Apply Text Either)))))) - (record$ (#Cons [(tag$ ["lux" "doc"]) - (text$ ("lux text concat" - ("lux text concat" "Computations that can have access to the state of the compiler." __paragraph) - "These computations may fail, or modify the state of the compiler."))] - (#Cons [(tag$ ["lux" "type-args"]) - (tuple$ (#Cons (text$ "a") #Nil))] - #Nil))) - #1) - -## (type: Macro' -## (-> (List Code) (Meta (List Code)))) -("lux def" Macro' - ("lux type check type" - (#Named ["lux" "Macro'"] - (#Function Code_List (#Apply Code_List Meta)))) - (record$ #Nil) - #1) - -## (type: Macro -## (primitive "#Macro")) -("lux def" Macro - ("lux type check type" - (#Named ["lux" "Macro"] - (#Primitive "#Macro" #Nil))) - (record$ (#Cons [(tag$ ["lux" "doc"]) - (text$ "Functions that run at compile-time and allow you to transform and extend the language in powerful ways.")] - #Nil)) - #1) - -## Base functions & macros -("lux def" return - ("lux type check" - (#UnivQ #Nil - (#Function (#Parameter 1) - (#Function Lux - (#Apply (#Product Lux - (#Parameter 1)) - (#Apply Text Either))))) - ([_ val] - ([_ state] - (#Right state val)))) - (record$ #Nil) - #0) - -("lux def" fail - ("lux type check" - (#UnivQ #Nil - (#Function Text - (#Function Lux - (#Apply (#Product Lux - (#Parameter 1)) - (#Apply Text Either))))) - ([_ msg] - ([_ state] - (#Left msg)))) - (record$ #Nil) - #0) - -("lux def" let'' - ("lux macro" - ([_ tokens] - ({(#Cons lhs (#Cons rhs (#Cons body #Nil))) - (return (#Cons (form$ (#Cons (record$ (#Cons [lhs body] #Nil)) (#Cons rhs #Nil))) - #Nil)) - - _ - (fail "Wrong syntax for let''")} - tokens))) - (record$ #.Nil) - #0) - -("lux def" function'' - ("lux macro" - ([_ tokens] - ({(#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil)) - (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" ""])) - (#Cons arg #Nil)))) - (#Cons ({#Nil - body - - _ - (_ann (#Form (#Cons (_ann (#Identifier ["lux" "function''"])) - (#Cons (_ann (#Tuple args')) - (#Cons body #Nil)))))} - args') - #Nil)))) - #Nil)) - - (#Cons [_ (#Identifier ["" self])] (#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil))) - (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" self])) - (#Cons arg #Nil)))) - (#Cons ({#Nil - body - - _ - (_ann (#Form (#Cons (_ann (#Identifier ["lux" "function''"])) - (#Cons (_ann (#Tuple args')) - (#Cons body #Nil)))))} - args') - #Nil)))) - #Nil)) - - _ - (fail "Wrong syntax for function''")} - tokens))) - (record$ #.Nil) - #0) - -("lux def" location_code - ("lux type check" Code - (tuple$ (#Cons (text$ "") (#Cons (nat$ 0) (#Cons (nat$ 0) #Nil))))) - (record$ #Nil) - #0) - -("lux def" meta_code - ("lux type check" (#Function Name (#Function Code Code)) - ([_ tag] - ([_ value] - (tuple$ (#Cons location_code - (#Cons (form$ (#Cons (tag$ tag) (#Cons value #Nil))) - #Nil)))))) - (record$ #Nil) - #0) - -("lux def" flag_meta - ("lux type check" (#Function Text Code) - ([_ tag] - (tuple$ (#Cons [(meta_code ["lux" "Tag"] (tuple$ (#Cons (text$ "lux") (#Cons (text$ tag) #Nil)))) - (#Cons [(meta_code ["lux" "Bit"] (bit$ #1)) - #Nil])])))) - (record$ #Nil) - #0) - -("lux def" doc_meta - ("lux type check" (#Function Text (#Product Code Code)) - (function'' [doc] [(tag$ ["lux" "doc"]) (text$ doc)])) - (record$ #Nil) - #0) - -("lux def" as_def - ("lux type check" (#Function Code (#Function Code (#Function Code (#Function Bit Code)))) - (function'' [name value annotations exported?] - (form$ (#Cons (text$ "lux def") (#Cons name (#Cons value (#Cons annotations (#Cons (bit$ exported?) #Nil)))))))) - (record$ #Nil) - #0) - -("lux def" as_checked - ("lux type check" (#Function Code (#Function Code Code)) - (function'' [type value] - (form$ (#Cons (text$ "lux type check") (#Cons type (#Cons value #Nil)))))) - (record$ #Nil) - #0) - -("lux def" as_function - ("lux type check" (#Function Code (#Function (#Apply Code List) (#Function Code Code))) - (function'' [self inputs output] - (form$ (#Cons (identifier$ ["lux" "function''"]) - (#Cons self - (#Cons (tuple$ inputs) - (#Cons output #Nil))))))) - (record$ #Nil) - #0) - -("lux def" as_macro - ("lux type check" (#Function Code Code) - (function'' [expression] - (form$ (#Cons (text$ "lux macro") - (#Cons expression - #Nil))))) - (record$ #Nil) - #0) - -("lux def" def:'' - ("lux macro" - (function'' [tokens] - ({(#Cons [[_ (#Tag ["" "export"])] - (#Cons [[_ (#Form (#Cons [name args]))] - (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) - (return (#Cons [(as_def name (as_checked type (as_function name args body)) - (form$ (#Cons (identifier$ ["lux" "record$"]) - (#Cons meta - #Nil))) - #1) - #Nil])) - - (#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) - (return (#Cons [(as_def name (as_checked type body) - (form$ (#Cons (identifier$ ["lux" "record$"]) - (#Cons meta - #Nil))) - #1) - #Nil])) - - (#Cons [[_ (#Form (#Cons [name args]))] - (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(as_def name (as_checked type (as_function name args body)) - (form$ (#Cons (identifier$ ["lux" "record$"]) - (#Cons meta - #Nil))) - #0) - #Nil])) - - (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(as_def name (as_checked type body) - (form$ (#Cons (identifier$ ["lux" "record$"]) - (#Cons meta - #Nil))) - #0) - #Nil])) - - _ - (fail "Wrong syntax for def''")} - tokens))) - (record$ #.Nil) - #0) - -("lux def" macro:' - ("lux macro" - (function'' [tokens] - ({(#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil)) - (return (#Cons (as_def name (as_macro (as_function name args body)) - (form$ (#Cons (identifier$ ["lux" "record$"]) - (#Cons (tag$ ["lux" "Nil"]) - #Nil))) - #0) - #Nil)) - - (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil))) - (return (#Cons (as_def name (as_macro (as_function name args body)) - (form$ (#Cons (identifier$ ["lux" "record$"]) - (#Cons (tag$ ["lux" "Nil"]) - #Nil))) - #1) - #Nil)) - - (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons meta_data (#Cons body #Nil)))) - (return (#Cons (as_def name (as_macro (as_function name args body)) - (form$ (#Cons (identifier$ ["lux" "record$"]) - (#Cons meta_data - #Nil))) - #1) - #Nil)) - - _ - (fail "Wrong syntax for macro:'")} - tokens))) - (record$ #.Nil) - #0) - -(macro:' #export (comment tokens) - (#Cons [(tag$ ["lux" "doc"]) - (text$ ("lux text concat" - ("lux text concat" "## Throws away any code given to it." __paragraph) - ("lux text concat" - ("lux text concat" "## Great for commenting-out code, while retaining syntax high-lighting and formatting in your text editor." __paragraph) - "(comment +1 +2 +3 +4)")))] - #Nil) - (return #Nil)) - -(macro:' ($' tokens) - ({(#Cons x #Nil) - (return tokens) - - (#Cons x (#Cons y xs)) - (return (#Cons (form$ (#Cons (identifier$ ["lux" "$'"]) - (#Cons (form$ (#Cons (tag$ ["lux" "Apply"]) - (#Cons y (#Cons x #Nil)))) - xs))) - #Nil)) - - _ - (fail "Wrong syntax for $'")} - tokens)) - -(def:'' (list\map f xs) - #Nil - (#UnivQ #Nil - (#UnivQ #Nil - (#Function (#Function (#Parameter 3) (#Parameter 1)) - (#Function ($' List (#Parameter 3)) - ($' List (#Parameter 1)))))) - ({#Nil - #Nil - - (#Cons x xs') - (#Cons (f x) (list\map f xs'))} - xs)) - -(def:'' RepEnv - #Nil - Type - ($' List (#Product Text Code))) - -(def:'' (make_env xs ys) - #Nil - (#Function ($' List Text) (#Function ($' List Code) RepEnv)) - ({[(#Cons x xs') (#Cons y ys')] - (#Cons [x y] (make_env xs' ys')) - - _ - #Nil} - [xs ys])) - -(def:'' (text\= reference sample) - #Nil - (#Function Text (#Function Text Bit)) - ("lux text =" reference sample)) - -(def:'' (get_rep key env) - #Nil - (#Function Text (#Function RepEnv ($' Maybe Code))) - ({#Nil - #None - - (#Cons [k v] env') - ({#1 - (#Some v) - - #0 - (get_rep key env')} - (text\= k key))} - env)) - -(def:'' (replace_syntax reps syntax) - #Nil - (#Function RepEnv (#Function Code Code)) - ({[_ (#Identifier "" name)] - ({(#Some replacement) - replacement - - #None - syntax} - (get_rep name reps)) - - [meta (#Form parts)] - [meta (#Form (list\map (replace_syntax reps) parts))] - - [meta (#Tuple members)] - [meta (#Tuple (list\map (replace_syntax reps) members))] - - [meta (#Record slots)] - [meta (#Record (list\map ("lux type check" (#Function (#Product Code Code) (#Product Code Code)) - (function'' [slot] - ({[k v] - [(replace_syntax reps k) (replace_syntax reps v)]} - slot))) - slots))] - - _ - syntax} - syntax)) - -(def:'' (n/* param subject) - (#.Cons (doc_meta "Nat(ural) multiplication.") #.Nil) - (#Function Nat (#Function Nat Nat)) - ("lux type as" Nat - ("lux i64 *" - ("lux type as" Int param) - ("lux type as" Int subject)))) - -(def:'' (update_parameters code) - #Nil - (#Function Code Code) - ({[_ (#Tuple members)] - (tuple$ (list\map update_parameters members)) - - [_ (#Record pairs)] - (record$ (list\map ("lux type check" (#Function (#Product Code Code) (#Product Code Code)) - (function'' [pair] - (let'' [name val] pair - [name (update_parameters val)]))) - pairs)) - - [_ (#Form (#Cons [_ (#Tag "lux" "Parameter")] (#Cons [_ (#Nat idx)] #Nil)))] - (form$ (#Cons (tag$ ["lux" "Parameter"]) (#Cons (nat$ ("lux i64 +" 2 idx)) #Nil))) - - [_ (#Form members)] - (form$ (list\map update_parameters members)) - - _ - code} - code)) - -(def:'' (parse_quantified_args args next) - #Nil - ## (-> (List Code) (-> (List Text) (Meta (List Code))) (Meta (List Code))) - (#Function ($' List Code) - (#Function (#Function ($' List Text) (#Apply ($' List Code) Meta)) - (#Apply ($' List Code) Meta) - )) - ({#Nil - (next #Nil) - - (#Cons [_ (#Identifier "" arg_name)] args') - (parse_quantified_args args' (function'' [names] (next (#Cons arg_name names)))) - - _ - (fail "Expected identifier.")} - args)) - -(def:'' (make_parameter idx) - #Nil - (#Function Nat Code) - (form$ (#Cons (tag$ ["lux" "Parameter"]) (#Cons (nat$ idx) #Nil)))) - -(def:'' (list\fold f init xs) - #Nil - ## (All [a b] (-> (-> b a a) a (List b) a)) - (#UnivQ #Nil (#UnivQ #Nil (#Function (#Function (#Parameter 1) - (#Function (#Parameter 3) - (#Parameter 3))) - (#Function (#Parameter 3) - (#Function ($' List (#Parameter 1)) - (#Parameter 3)))))) - ({#Nil - init - - (#Cons x xs') - (list\fold f (f x init) xs')} - xs)) - -(def:'' (list\size list) - #Nil - (#UnivQ #Nil - (#Function ($' List (#Parameter 1)) Nat)) - (list\fold (function'' [_ acc] ("lux i64 +" 1 acc)) 0 list)) - -(macro:' #export (All tokens) - (#Cons [(tag$ ["lux" "doc"]) - (text$ ("lux text concat" - ("lux text concat" "## Universal quantification." __paragraph) - ("lux text concat" - ("lux text concat" "(All [a] (-> a a))" __paragraph) - ("lux text concat" - ("lux text concat" "## A name can be provided, to specify a recursive type." __paragraph) - "(All List [a] (| Any [a (List a)]))"))))] - #Nil) - (let'' [self_name tokens] ({(#Cons [_ (#Identifier "" self_name)] tokens) - [self_name tokens] - - _ - ["" tokens]} - tokens) - ({(#Cons [_ (#Tuple args)] (#Cons body #Nil)) - (parse_quantified_args args - (function'' [names] - (let'' body' (list\fold ("lux type check" (#Function Text (#Function Code Code)) - (function'' [name' body'] - (form$ (#Cons (tag$ ["lux" "UnivQ"]) - (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace_syntax (#Cons [name' (make_parameter 1)] #Nil) - (update_parameters body')) #Nil)))))) - body - names) - (return (#Cons ({[#1 _] - body' - - [_ #Nil] - body' - - [#0 _] - (replace_syntax (#Cons [self_name (make_parameter (n/* 2 ("lux i64 -" 1 (list\size names))))] - #Nil) - body')} - [(text\= "" self_name) names]) - #Nil))))) - - _ - (fail "Wrong syntax for All")} - tokens))) - -(macro:' #export (Ex tokens) - (#Cons [(tag$ ["lux" "doc"]) - (text$ ("lux text concat" - ("lux text concat" "## Existential quantification." __paragraph) - ("lux text concat" - ("lux text concat" "(Ex [a] [(Codec Text a) a])" __paragraph) - ("lux text concat" - ("lux text concat" "## A name can be provided, to specify a recursive type." __paragraph) - "(Ex Self [a] [(Codec Text a) a (List (Self a))])"))))] - #Nil) - (let'' [self_name tokens] ({(#Cons [_ (#Identifier "" self_name)] tokens) - [self_name tokens] - - _ - ["" tokens]} - tokens) - ({(#Cons [_ (#Tuple args)] (#Cons body #Nil)) - (parse_quantified_args args - (function'' [names] - (let'' body' (list\fold ("lux type check" (#Function Text (#Function Code Code)) - (function'' [name' body'] - (form$ (#Cons (tag$ ["lux" "ExQ"]) - (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace_syntax (#Cons [name' (make_parameter 1)] #Nil) - (update_parameters body')) #Nil)))))) - body - names) - (return (#Cons ({[#1 _] - body' - - [_ #Nil] - body' - - [#0 _] - (replace_syntax (#Cons [self_name (make_parameter (n/* 2 ("lux i64 -" 1 (list\size names))))] - #Nil) - body')} - [(text\= "" self_name) names]) - #Nil))))) - - _ - (fail "Wrong syntax for Ex")} - tokens))) - -(def:'' (list\reverse list) - #Nil - (All [a] (#Function ($' List a) ($' List a))) - (list\fold ("lux type check" (All [a] (#Function a (#Function ($' List a) ($' List a)))) - (function'' [head tail] (#Cons head tail))) - #Nil - list)) - -(macro:' #export (-> tokens) - (#Cons [(tag$ ["lux" "doc"]) - (text$ ("lux text concat" - ("lux text concat" "## Function types:" __paragraph) - ("lux text concat" - ("lux text concat" "(-> Int Int Int)" __paragraph) - "## This is the type of a function that takes 2 Ints and returns an Int.")))] - #Nil) - ({(#Cons output inputs) - (return (#Cons (list\fold ("lux type check" (#Function Code (#Function Code Code)) - (function'' [i o] (form$ (#Cons (tag$ ["lux" "Function"]) (#Cons i (#Cons o #Nil)))))) - output - inputs) - #Nil)) - - _ - (fail "Wrong syntax for ->")} - (list\reverse tokens))) - -(macro:' #export (list xs) - (#Cons [(tag$ ["lux" "doc"]) - (text$ ("lux text concat" - ("lux text concat" "## List-construction macro." __paragraph) - "(list +1 +2 +3)"))] - #Nil) - (return (#Cons (list\fold (function'' [head tail] - (form$ (#Cons (tag$ ["lux" "Cons"]) - (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) - #Nil)))) - (tag$ ["lux" "Nil"]) - (list\reverse xs)) - #Nil))) - -(macro:' #export (list& xs) - (#Cons [(tag$ ["lux" "doc"]) - (text$ ("lux text concat" - ("lux text concat" "## List-construction macro, with the last element being a tail-list." __paragraph) - ("lux text concat" - ("lux text concat" "## In other words, this macro prepends elements to another list." __paragraph) - "(list& +1 +2 +3 (list +4 +5 +6))")))] - #Nil) - ({(#Cons last init) - (return (list (list\fold (function'' [head tail] - (form$ (list (tag$ ["lux" "Cons"]) - (tuple$ (list head tail))))) - last - init))) - - _ - (fail "Wrong syntax for list&")} - (list\reverse xs))) - -(macro:' #export (& tokens) - (#Cons [(tag$ ["lux" "doc"]) - (text$ ("lux text concat" - ("lux text concat" "## Tuple types:" __paragraph) - ("lux text concat" - ("lux text concat" "(& Text Int Bit)" __paragraph) - ("lux text concat" - ("lux text concat" "## Any." __paragraph) - "(&)"))))] - #Nil) - ({#Nil - (return (list (identifier$ ["lux" "Any"]))) - - (#Cons last prevs) - (return (list (list\fold (function'' [left right] (form$ (list (tag$ ["lux" "Product"]) left right))) - last - prevs)))} - (list\reverse tokens))) - -(macro:' #export (| tokens) - (#Cons [(tag$ ["lux" "doc"]) - (text$ ("lux text concat" - ("lux text concat" "## Variant types:" __paragraph) - ("lux text concat" - ("lux text concat" "(| Text Int Bit)" __paragraph) - ("lux text concat" - ("lux text concat" "## Nothing." __paragraph) - "(|)"))))] - #Nil) - ({#Nil - (return (list (identifier$ ["lux" "Nothing"]))) - - (#Cons last prevs) - (return (list (list\fold (function'' [left right] (form$ (list (tag$ ["lux" "Sum"]) left right))) - last - prevs)))} - (list\reverse tokens))) - -(macro:' (function' tokens) - (let'' [name tokens'] ({(#Cons [[_ (#Identifier ["" name])] tokens']) - [name tokens'] - - _ - ["" tokens]} - tokens) - ({(#Cons [[_ (#Tuple args)] (#Cons [body #Nil])]) - ({#Nil - (fail "function' requires a non-empty arguments tuple.") - - (#Cons [harg targs]) - (return (list (form$ (list (tuple$ (list (local_identifier$ name) - harg)) - (list\fold (function'' [arg body'] - (form$ (list (tuple$ (list (local_identifier$ "") - arg)) - body'))) - body - (list\reverse targs))))))} - args) - - _ - (fail "Wrong syntax for function'")} - tokens'))) - -(macro:' (def:''' tokens) - ({(#Cons [[_ (#Tag ["" "export"])] - (#Cons [[_ (#Form (#Cons [name args]))] - (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) - (return (list (form$ (list (text$ "lux def") - name - (form$ (list (text$ "lux type check") - type - (form$ (list (identifier$ ["lux" "function'"]) - name - (tuple$ args) - body)))) - (form$ (#Cons (identifier$ ["lux" "record$"]) - (#Cons meta - #Nil))) - (bit$ #1))))) - - (#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) - (return (list (form$ (list (text$ "lux def") - name - (form$ (list (text$ "lux type check") - type - body)) - (form$ (#Cons (identifier$ ["lux" "record$"]) - (#Cons meta - #Nil))) - (bit$ #1))))) - - (#Cons [[_ (#Form (#Cons [name args]))] - (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) - (return (list (form$ (list (text$ "lux def") - name - (form$ (list (text$ "lux type check") - type - (form$ (list (identifier$ ["lux" "function'"]) - name - (tuple$ args) - body)))) - (form$ (#Cons (identifier$ ["lux" "record$"]) - (#Cons meta - #Nil))) - (bit$ #0))))) - - (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) - (return (list (form$ (list (text$ "lux def") - name - (form$ (list (text$ "lux type check") type body)) - (form$ (#Cons (identifier$ ["lux" "record$"]) - (#Cons meta - #Nil))) - (bit$ #0))))) - - _ - (fail "Wrong syntax for def:'''")} - tokens)) - -(def:''' (as_pairs xs) - #Nil - (All [a] (-> ($' List a) ($' List (& a a)))) - ({(#Cons x (#Cons y xs')) - (#Cons [x y] (as_pairs xs')) - - _ - #Nil} - xs)) - -(macro:' (let' tokens) - ({(#Cons [[_ (#Tuple bindings)] (#Cons [body #Nil])]) - (return (list (list\fold ("lux type check" (-> (& Code Code) Code - Code) - (function' [binding body] - ({[label value] - (form$ (list (record$ (list [label body])) value))} - binding))) - body - (list\reverse (as_pairs bindings))))) - - _ - (fail "Wrong syntax for let'")} - tokens)) - -(def:''' (any? p xs) - #Nil - (All [a] - (-> (-> a Bit) ($' List a) Bit)) - ({#Nil - #0 - - (#Cons x xs') - ({#1 #1 - #0 (any? p xs')} - (p x))} - xs)) - -(def:''' (wrap_meta content) - #Nil - (-> Code Code) - (tuple$ (list (tuple$ (list (text$ "") (nat$ 0) (nat$ 0))) - content))) - -(def:''' (untemplate_list tokens) - #Nil - (-> ($' List Code) Code) - ({#Nil - (_ann (#Tag ["lux" "Nil"])) - - (#Cons [token tokens']) - (_ann (#Form (list (_ann (#Tag ["lux" "Cons"])) token (untemplate_list tokens'))))} - tokens)) - -(def:''' (list\compose xs ys) - #Nil - (All [a] (-> ($' List a) ($' List a) ($' List a))) - ({(#Cons x xs') - (#Cons x (list\compose xs' ys)) - - #Nil - ys} - xs)) - -(def:''' (_$_joiner op a1 a2) - #Nil - (-> Code Code Code Code) - ({[_ (#Form parts)] - (form$ (list\compose parts (list a1 a2))) - - _ - (form$ (list op a1 a2))} - op)) - -(def:''' (function/flip func) - #Nil - (All [a b c] - (-> (-> a b c) (-> b a c))) - (function' [right left] - (func left right))) - -(macro:' #export (_$ tokens) - (#Cons [(tag$ ["lux" "doc"]) - (text$ ("lux text concat" - ("lux text concat" "## Left-association for the application of binary functions over variadic arguments." ..\n) - ("lux text concat" - ("lux text concat" "(_$ text\compose ''Hello, '' name ''. How are you?'')" ..\n) - ("lux text concat" - ("lux text concat" "## =>" ..\n) - "(text\compose (text\compose ''Hello, '' name) ''. How are you?'')"))))] - #Nil) - ({(#Cons op tokens') - ({(#Cons first nexts) - (return (list (list\fold (function/flip (_$_joiner op)) first nexts))) - - _ - (fail "Wrong syntax for _$")} - tokens') - - _ - (fail "Wrong syntax for _$")} - tokens)) - -(macro:' #export ($_ tokens) - (#Cons [(tag$ ["lux" "doc"]) - (text$ ("lux text concat" - ("lux text concat" "## Right-association for the application of binary functions over variadic arguments." ..\n) - ("lux text concat" - ("lux text concat" "($_ text\compose ''Hello, '' name ''. How are you?'')" ..\n) - ("lux text concat" - ("lux text concat" "## =>" ..\n) - "(text\compose ''Hello, '' (text\compose name ''. How are you?''))"))))] - #Nil) - ({(#Cons op tokens') - ({(#Cons last prevs) - (return (list (list\fold (_$_joiner op) last prevs))) - - _ - (fail "Wrong syntax for $_")} - (list\reverse tokens')) - - _ - (fail "Wrong syntax for $_")} - tokens)) - -## (interface: (Monad m) -## (: (All [a] (-> a (m a))) -## wrap) -## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) -## bind)) -("lux def type tagged" Monad - (#Named ["lux" "Monad"] - (All [m] - (& (All [a] (-> a ($' m a))) - (All [a b] (-> (-> a ($' m b)) - ($' m a) - ($' m b)))))) - (record$ (list)) - ["wrap" "bind"] - #0) - -(def:''' maybe_monad - #Nil - ($' Monad Maybe) - {#wrap - (function' [x] (#Some x)) - - #bind - (function' [f ma] - ({#None #None - (#Some a) (f a)} - ma))}) - -(def:''' meta_monad - #Nil - ($' Monad Meta) - {#wrap - (function' [x] - (function' [state] - (#Right state x))) - - #bind - (function' [f ma] - (function' [state] - ({(#Left msg) - (#Left msg) - - (#Right [state' a]) - (f a state')} - (ma state))))}) - -(macro:' (do tokens) - ({(#Cons monad (#Cons [_ (#Tuple bindings)] (#Cons body #Nil))) - (let' [g!wrap (local_identifier$ "wrap") - g!bind (local_identifier$ " bind ") - body' (list\fold ("lux type check" (-> (& Code Code) Code Code) - (function' [binding body'] - (let' [[var value] binding] - ({[_ (#Tag "" "let")] - (form$ (list (identifier$ ["lux" "let'"]) value body')) - - _ - (form$ (list g!bind - (form$ (list (tuple$ (list (local_identifier$ "") var)) body')) - value))} - var)))) - body - (list\reverse (as_pairs bindings)))] - (return (list (form$ (list (record$ (list [(record$ (list [(tag$ ["lux" "wrap"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) - body'])) - monad))))) - - _ - (fail "Wrong syntax for do")} - tokens)) - -(def:''' (monad\map m f xs) - #Nil - ## (All [m a b] - ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) - (All [m a b] - (-> ($' Monad m) - (-> a ($' m b)) - ($' List a) - ($' m ($' List b)))) - (let' [{#wrap wrap #bind _} m] - ({#Nil - (wrap #Nil) - - (#Cons x xs') - (do m - [y (f x) - ys (monad\map m f xs')] - (wrap (#Cons y ys)))} - xs))) - -(def:''' (monad\fold m f y xs) - #Nil - ## (All [m a b] - ## (-> (Monad m) (-> a b (m b)) b (List a) (m b))) - (All [m a b] - (-> ($' Monad m) - (-> a b ($' m b)) - b - ($' List a) - ($' m b))) - (let' [{#wrap wrap #bind _} m] - ({#Nil - (wrap y) - - (#Cons x xs') - (do m - [y' (f x y)] - (monad\fold m f y' xs'))} - xs))) - -(macro:' #export (if tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "Picks which expression to evaluate based on a bit test value." __paragraph - "(if #1 ''Oh, yeah!'' ''Aw hell naw!'')" __paragraph - "=> ''Oh, yeah!''"))]) - ({(#Cons test (#Cons then (#Cons else #Nil))) - (return (list (form$ (list (record$ (list [(bit$ #1) then] - [(bit$ #0) else])) - test)))) - - _ - (fail "Wrong syntax for if")} - tokens)) - -(def:''' (get k plist) - #Nil - (All [a] - (-> Text ($' List (& Text a)) ($' Maybe a))) - ({(#Cons [[k' v] plist']) - (if (text\= k k') - (#Some v) - (get k plist')) - - #Nil - #None} - plist)) - -(def:''' (put k v dict) - #Nil - (All [a] - (-> Text a ($' List (& Text a)) ($' List (& Text a)))) - ({#Nil - (list [k v]) - - (#Cons [[k' v'] dict']) - (if (text\= k k') - (#Cons [[k' v] dict']) - (#Cons [[k' v'] (put k v dict')]))} - dict)) - -(def:''' (text\compose x y) - #Nil - (-> Text Text Text) - ("lux text concat" x y)) - -(def:''' (name\encode full_name) - #Nil - (-> Name Text) - (let' [[module name] full_name] - ({"" name - _ ($_ text\compose module "." name)} - module))) - -(def:''' (get_meta tag def_meta) - #Nil - (-> Name Code ($' Maybe Code)) - (let' [[prefix name] tag] - ({[_ (#Record def_meta)] - ({(#Cons [key value] def_meta') - ({[_ (#Tag [prefix' name'])] - ({[#1 #1] - (#Some value) - - _ - (get_meta tag (record$ def_meta'))} - [(text\= prefix prefix') - (text\= name name')]) - - _ - (get_meta tag (record$ def_meta'))} - key) - - #Nil - #None} - def_meta) - - _ - #None} - def_meta))) - -(def:''' (resolve_global_identifier full_name state) - #Nil - (-> Name ($' Meta Name)) - (let' [[module name] full_name - {#info info #source source #current_module _ #modules modules - #scopes scopes #type_context types #host host - #seed seed #expected expected #location location #extensions extensions - #scope_type_vars scope_type_vars} state] - ({(#Some {#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _}) - ({(#Some constant) - ({(#Left real_name) - (#Right [state real_name]) - - (#Right [exported? def_type def_meta def_value]) - (#Right [state full_name])} - constant) - - #None - (#Left ($_ text\compose "Unknown definition: " (name\encode full_name)))} - (get name definitions)) - - #None - (#Left ($_ text\compose "Unknown module: " module " @ " (name\encode full_name)))} - (get module modules)))) - -(def:''' (as_code_list expression) - #Nil - (-> Code Code) - (let' [type (form$ (list (tag$ ["lux" "Apply"]) - (identifier$ ["lux" "Code"]) - (identifier$ ["lux" "List"])))] - (form$ (list (text$ "lux type check") type expression)))) - -(def:''' (splice replace? untemplate elems) - #Nil - (-> Bit (-> Code ($' Meta Code)) ($' List Code) ($' Meta Code)) - ({#1 - ({#Nil - (return (tag$ ["lux" "Nil"])) - - (#Cons lastI inits) - (do meta_monad - [lastO ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] - (wrap (as_code_list spliced)) - - _ - (do meta_monad - [lastO (untemplate lastI)] - (wrap (as_code_list (form$ (list (tag$ ["lux" "Cons"]) - (tuple$ (list lastO (tag$ ["lux" "Nil"]))))))))} - lastI)] - (monad\fold meta_monad - (function' [leftI rightO] - ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] - (let' [g!in-module (form$ (list (text$ "lux in-module") - (text$ "lux") - (identifier$ ["lux" "list\compose"])))] - (wrap (form$ (list g!in-module (as_code_list spliced) rightO)))) - - _ - (do meta_monad - [leftO (untemplate leftI)] - (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list leftO rightO))))))} - leftI)) - lastO - inits))} - (list\reverse elems)) - #0 - (do meta_monad - [=elems (monad\map meta_monad untemplate elems)] - (wrap (untemplate_list =elems)))} - replace?)) - -(def:''' (untemplate_text value) - #Nil - (-> Text Code) - (wrap_meta (form$ (list (tag$ ["lux" "Text"]) (text$ value))))) - -(def:''' (untemplate replace? subst token) - #Nil - (-> Bit Text Code ($' Meta Code)) - ({[_ [_ (#Bit value)]] - (return (wrap_meta (form$ (list (tag$ ["lux" "Bit"]) (bit$ value))))) - - [_ [_ (#Nat value)]] - (return (wrap_meta (form$ (list (tag$ ["lux" "Nat"]) (nat$ value))))) - - [_ [_ (#Int value)]] - (return (wrap_meta (form$ (list (tag$ ["lux" "Int"]) (int$ value))))) - - [_ [_ (#Rev value)]] - (return (wrap_meta (form$ (list (tag$ ["lux" "Rev"]) (rev$ value))))) - - [_ [_ (#Frac value)]] - (return (wrap_meta (form$ (list (tag$ ["lux" "Frac"]) (frac$ value))))) - - [_ [_ (#Text value)]] - (return (untemplate_text value)) - - [#0 [_ (#Tag [module name])]] - (return (wrap_meta (form$ (list (tag$ ["lux" "Tag"]) (tuple$ (list (text$ module) (text$ name))))))) - - [#1 [_ (#Tag [module name])]] - (let' [module' ({"" - subst - - _ - module} - module)] - (return (wrap_meta (form$ (list (tag$ ["lux" "Tag"]) (tuple$ (list (text$ module') (text$ name)))))))) - - [#1 [_ (#Identifier [module name])]] - (do meta_monad - [real_name ({"" - (if (text\= "" subst) - (wrap [module name]) - (resolve_global_identifier [subst name])) - - _ - (wrap [module name])} - module) - #let [[module name] real_name]] - (return (wrap_meta (form$ (list (tag$ ["lux" "Identifier"]) (tuple$ (list (text$ module) (text$ name)))))))) - - [#0 [_ (#Identifier [module name])]] - (return (wrap_meta (form$ (list (tag$ ["lux" "Identifier"]) (tuple$ (list (text$ module) (text$ name))))))) - - [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))]] - (return (form$ (list (text$ "lux type check") - (identifier$ ["lux" "Code"]) - unquoted))) - - [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~!"])] (#Cons [dependent #Nil])]))]] - (do meta_monad - [independent (untemplate replace? subst dependent)] - (wrap (wrap_meta (form$ (list (tag$ ["lux" "Form"]) - (untemplate_list (list (untemplate_text "lux in-module") - (untemplate_text subst) - independent))))))) - - [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~'"])] (#Cons [keep_quoted #Nil])]))]] - (untemplate #0 subst keep_quoted) - - [_ [meta (#Form elems)]] - (do meta_monad - [output (splice replace? (untemplate replace? subst) elems) - #let [[_ output'] (wrap_meta (form$ (list (tag$ ["lux" "Form"]) output)))]] - (wrap [meta output'])) - - [_ [meta (#Tuple elems)]] - (do meta_monad - [output (splice replace? (untemplate replace? subst) elems) - #let [[_ output'] (wrap_meta (form$ (list (tag$ ["lux" "Tuple"]) output)))]] - (wrap [meta output'])) - - [_ [_ (#Record fields)]] - (do meta_monad - [=fields (monad\map meta_monad - ("lux type check" (-> (& Code Code) ($' Meta Code)) - (function' [kv] - (let' [[k v] kv] - (do meta_monad - [=k (untemplate replace? subst k) - =v (untemplate replace? subst v)] - (wrap (tuple$ (list =k =v))))))) - fields)] - (wrap (wrap_meta (form$ (list (tag$ ["lux" "Record"]) (untemplate_list =fields))))))} - [replace? token])) - -(macro:' #export (primitive tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Macro to treat define new primitive types." __paragraph - "(primitive ''java.lang.Object'')" __paragraph - "(primitive ''java.util.List'' [(primitive ''java.lang.Long'')])"))]) - ({(#Cons [_ (#Text class_name)] #Nil) - (return (list (form$ (list (tag$ ["lux" "Primitive"]) (text$ class_name) (tag$ ["lux" "Nil"]))))) - - (#Cons [_ (#Text class_name)] (#Cons [_ (#Tuple params)] #Nil)) - (return (list (form$ (list (tag$ ["lux" "Primitive"]) (text$ class_name) (untemplate_list params))))) - - _ - (fail "Wrong syntax for primitive")} - tokens)) - -(def:'' (current_module_name state) - #Nil - ($' Meta Text) - ({{#info info #source source #current_module current_module #modules modules - #scopes scopes #type_context types #host host - #seed seed #expected expected #location location #extensions extensions - #scope_type_vars scope_type_vars} - ({(#Some module_name) - (#Right [state module_name]) - - _ - (#Left "Cannot get the module name without a module!")} - current_module)} - state)) - -(macro:' #export (` tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Hygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph - "## All unprefixed macros will receive their parent module's prefix if imported; otherwise will receive the prefix of the module on which the quasi-quote is being used." __paragraph - "(` (def: (~ name) (function ((~' _) (~+ args)) (~ body))))"))]) - ({(#Cons template #Nil) - (do meta_monad - [current_module current_module_name - =template (untemplate #1 current_module template)] - (wrap (list (form$ (list (text$ "lux type check") - (identifier$ ["lux" "Code"]) - =template))))) - - _ - (fail "Wrong syntax for `")} - tokens)) - -(macro:' #export (`' tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph - "(`' (def: (~ name) (function (_ (~+ args)) (~ body))))"))]) - ({(#Cons template #Nil) - (do meta_monad - [=template (untemplate #1 "" template)] - (wrap (list (form$ (list (text$ "lux type check") (identifier$ ["lux" "Code"]) =template))))) - - _ - (fail "Wrong syntax for `")} - tokens)) - -(macro:' #export (' tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Quotation as a macro." __paragraph - "(' YOLO)"))]) - ({(#Cons template #Nil) - (do meta_monad - [=template (untemplate #0 "" template)] - (wrap (list (form$ (list (text$ "lux type check") (identifier$ ["lux" "Code"]) =template))))) - - _ - (fail "Wrong syntax for '")} - tokens)) - -(macro:' #export (|> tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Piping macro." __paragraph - "(|> elems (list\map int\encode) (interpose '' '') (fold text\compose ''''))" __paragraph - "## =>" __paragraph - "(fold text\compose '''' (interpose '' '' (list\map int\encode elems)))"))]) - ({(#Cons [init apps]) - (return (list (list\fold ("lux type check" (-> Code Code Code) - (function' [app acc] - ({[_ (#Tuple parts)] - (tuple$ (list\compose parts (list acc))) - - [_ (#Form parts)] - (form$ (list\compose parts (list acc))) - - _ - (` ((~ app) (~ acc)))} - app))) - init - apps))) - - _ - (fail "Wrong syntax for |>")} - tokens)) - -(macro:' #export (<| tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Reverse piping macro." __paragraph - "(<| (fold text\compose '''') (interpose '' '') (list\map int\encode) elems)" __paragraph - "## =>" __paragraph - "(fold text\compose '''' (interpose '' '' (list\map int\encode elems)))"))]) - ({(#Cons [init apps]) - (return (list (list\fold ("lux type check" (-> Code Code Code) - (function' [app acc] - ({[_ (#Tuple parts)] - (tuple$ (list\compose parts (list acc))) - - [_ (#Form parts)] - (form$ (list\compose parts (list acc))) - - _ - (` ((~ app) (~ acc)))} - app))) - init - apps))) - - _ - (fail "Wrong syntax for <|")} - (list\reverse tokens))) - -(def:''' (compose f g) - (list [(tag$ ["lux" "doc"]) - (text$ "Function composition.")]) - (All [a b c] - (-> (-> b c) (-> a b) (-> a c))) - (function' [x] (f (g x)))) - -(def:''' (get_name x) - #Nil - (-> Code ($' Maybe Name)) - ({[_ (#Identifier sname)] - (#Some sname) - - _ - #None} - x)) - -(def:''' (get_tag x) - #Nil - (-> Code ($' Maybe Name)) - ({[_ (#Tag sname)] - (#Some sname) - - _ - #None} - x)) - -(def:''' (get_short x) - #Nil - (-> Code ($' Maybe Text)) - ({[_ (#Identifier "" sname)] - (#Some sname) - - _ - #None} - x)) - -(def:''' (tuple->list tuple) - #Nil - (-> Code ($' Maybe ($' List Code))) - ({[_ (#Tuple members)] - (#Some members) - - _ - #None} - tuple)) - -(def:''' (apply_template env template) - #Nil - (-> RepEnv Code Code) - ({[_ (#Identifier "" sname)] - ({(#Some subst) - subst - - _ - template} - (get_rep sname env)) - - [meta (#Tuple elems)] - [meta (#Tuple (list\map (apply_template env) elems))] - - [meta (#Form elems)] - [meta (#Form (list\map (apply_template env) elems))] - - [meta (#Record members)] - [meta (#Record (list\map ("lux type check" (-> (& Code Code) (& Code Code)) - (function' [kv] - (let' [[slot value] kv] - [(apply_template env slot) (apply_template env value)]))) - members))] - - _ - template} - template)) - -(def:''' (every? p xs) - #Nil - (All [a] - (-> (-> a Bit) ($' List a) Bit)) - (list\fold (function' [_2 _1] (if _1 (p _2) #0)) #1 xs)) - -(def:''' (high_bits value) - (list) - (-> ($' I64 Any) I64) - ("lux i64 right-shift" 32 value)) - -(def:''' low_mask - (list) - I64 - (|> 1 ("lux i64 left-shift" 32) ("lux i64 -" 1))) - -(def:''' (low_bits value) - (list) - (-> ($' I64 Any) I64) - ("lux i64 and" low_mask value)) - -(def:''' (n/< reference sample) - (list) - (-> Nat Nat Bit) - (let' [referenceH (high_bits reference) - sampleH (high_bits sample)] - (if ("lux i64 <" referenceH sampleH) - #1 - (if ("lux i64 =" referenceH sampleH) - ("lux i64 <" - (low_bits reference) - (low_bits sample)) - #0)))) - -(def:''' (n/<= reference sample) - (list) - (-> Nat Nat Bit) - (if (n/< reference sample) - #1 - ("lux i64 =" reference sample))) - -(def:''' (list\join xs) - #Nil - (All [a] - (-> ($' List ($' List a)) ($' List a))) - (list\fold list\compose #Nil (list\reverse xs))) - -(macro:' #export (template tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary." __paragraph - "(template [ ]" ..\n - " " "[(def: #export (-> Int Int) (+ ))]" __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$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Bit negation." __paragraph - "(not #1) => #0" __paragraph - "(not #0) => #1"))]) - (-> Bit Bit) - (if x #0 #1)) - -(def:''' (macro_type? type) - (list) - (-> Type Bit) - ({(#Named ["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$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Takes a type expression and returns it's representation as data-structure." __paragraph - "(type (All [a] (Maybe (List a))))"))]) - ({(#Cons type #Nil) - (do meta_monad - [type+ (macro_expand_all type)] - ({(#Cons type' #Nil) - (wrap (list (walk_type type'))) - - _ - (fail "The expansion of the type-syntax had to yield a single element.")} - type+)) - - _ - (fail "Wrong syntax for type")} - tokens)) - -(macro:' #export (: tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## The type-annotation macro." __paragraph - "(: (List Int) (list +1 +2 +3))"))]) - ({(#Cons type (#Cons value #Nil)) - (return (list (` ("lux type check" (type (~ type)) (~ value))))) - - _ - (fail "Wrong syntax for :")} - tokens)) - -(macro:' #export (:as tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## The type-coercion macro." __paragraph - "(:as Dinosaur (list +1 +2 +3))"))]) - ({(#Cons type (#Cons value #Nil)) - (return (list (` ("lux type as" (type (~ type)) (~ value))))) - - _ - (fail "Wrong syntax for :as")} - tokens)) - -(def:''' (empty? xs) - #Nil - (All [a] (-> ($' List a) Bit)) - ({#Nil #1 - _ #0} - xs)) - -(template [ ] - [(def:''' ( xy) - #Nil - (All [a b] (-> (& a b) )) - (let' [[x y] xy] ))] - - [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$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Parameter-less recursive types." __paragraph - "## A name has to be given to the whole type, to use it within its body." __paragraph - "(Rec Self [Int (List Self)])"))]) - ({(#Cons [_ (#Identifier "" name)] (#Cons body #Nil)) - (let' [body' (replace_syntax (list [name (` (#.Apply (~ (make_parameter 1)) (~ (make_parameter 0))))]) - (update_parameters body))] - (return (list (` (#.Apply .Nothing (#.UnivQ #.Nil (~ body'))))))) - - _ - (fail "Wrong syntax for Rec")} - tokens)) - -(macro:' #export (exec tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Sequential execution of expressions (great for side-effects)." __paragraph - "(exec" ..\n - " " "(log! ''#1'')" ..\n - " " "(log! ''#2'')" ..\n - " " "(log! ''#3'')" ..\n - "''YOLO'')"))]) - ({(#Cons value actions) - (let' [dummy (local_identifier$ "")] - (return (list (list\fold ("lux type check" (-> Code Code Code) - (function' [pre post] (` ({(~ dummy) (~ post)} - (~ pre))))) - value - actions)))) - - _ - (fail "Wrong syntax for exec")} - (list\reverse tokens))) - -(macro:' (def:' tokens) - (let' [[export? tokens'] ({(#Cons [_ (#Tag ["" "export"])] tokens') - [#1 tokens'] - - _ - [#0 tokens]} - tokens) - parts (: (Maybe [Code (List Code) (Maybe Code) Code]) - ({(#Cons [_ (#Form (#Cons name args))] (#Cons type (#Cons body #Nil))) - (#Some name args (#Some type) body) - - (#Cons name (#Cons type (#Cons body #Nil))) - (#Some name #Nil (#Some type) body) - - (#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil)) - (#Some name args #None body) - - (#Cons name (#Cons body #Nil)) - (#Some name #Nil #None body) - - _ - #None} - tokens'))] - ({(#Some name args ?type body) - (let' [body' ({#Nil - body - - _ - (` (function' (~ name) [(~+ args)] (~ body)))} - args) - body'' ({(#Some type) - (` (: (~ type) (~ body'))) - - #None - body'} - ?type)] - (return (list (` ("lux def" (~ name) - (~ body'') - [(~ location_code) - (#.Record #.Nil)] - (~ (bit$ export?))))))) - - #None - (fail "Wrong syntax for def'")} - parts))) - -(def:' (rejoin_pair pair) - (-> [Code Code] (List Code)) - (let' [[left right] pair] - (list left right))) - -(def:' (text\encode original) - (-> Text Text) - ($_ text\compose ..double_quote original ..double_quote)) - -(def:' (code\encode code) - (-> Code Text) - ({[_ (#Bit value)] - (bit\encode value) - - [_ (#Nat value)] - (nat\encode value) - - [_ (#Int value)] - (int\encode value) - - [_ (#Rev value)] - ("lux io error" "@code\encode Undefined behavior.") - - [_ (#Frac value)] - (frac\encode value) - - [_ (#Text value)] - (text\encode value) - - [_ (#Identifier [prefix name])] - (if (text\= "" prefix) - name - ($_ text\compose prefix "." name)) - - [_ (#Tag [prefix name])] - (if (text\= "" prefix) - ($_ text\compose "#" name) - ($_ text\compose "#" prefix "." name)) - - [_ (#Form xs)] - ($_ text\compose "(" (|> xs - (list\map code\encode) - (interpose " ") - list\reverse - (list\fold text\compose "")) ")") - - [_ (#Tuple xs)] - ($_ text\compose "[" (|> xs - (list\map code\encode) - (interpose " ") - list\reverse - (list\fold text\compose "")) "]") - - [_ (#Record kvs)] - ($_ text\compose "{" (|> kvs - (list\map (function' [kv] ({[k v] ($_ text\compose (code\encode k) " " (code\encode v))} - kv))) - (interpose " ") - list\reverse - (list\fold text\compose "")) "}")} - code)) - -(def:' (expander branches) - (-> (List Code) (Meta (List Code))) - ({(#Cons [_ (#Form (#Cons [_ (#Identifier macro_name)] macro_args))] - (#Cons body - branches')) - (do meta_monad - [??? (macro? macro_name)] - (if ??? - (do meta_monad - [init_expansion (macro_expand_once (form$ (list& (identifier$ macro_name) (form$ macro_args) body branches')))] - (expander init_expansion)) - (do meta_monad - [sub_expansion (expander branches')] - (wrap (list& (form$ (list& (identifier$ macro_name) macro_args)) - body - sub_expansion))))) - - (#Cons pattern (#Cons body branches')) - (do meta_monad - [sub_expansion (expander branches')] - (wrap (list& pattern body sub_expansion))) - - #Nil - (do meta_monad [] (wrap (list))) - - _ - (fail ($_ text\compose "'lux.case' expects an even number of tokens: " (|> branches - (list\map code\encode) - (interpose " ") - list\reverse - (list\fold text\compose ""))))} - branches)) - -(macro:' #export (case tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## The pattern-matching macro." ..\n - "## Allows the usage of macros within the patterns to provide custom syntax." ..\n - "(case (: (List Int) (list +1 +2 +3))" ..\n - " " "(#Cons x (#Cons y (#Cons z #Nil)))" ..\n - " " "(#Some ($_ * x y z))" __paragraph - " " "_" ..\n - " " "#None)"))]) - ({(#Cons value branches) - (do meta_monad - [expansion (expander branches)] - (wrap (list (` ((~ (record$ (as_pairs expansion))) (~ value)))))) - - _ - (fail "Wrong syntax for case")} - tokens)) - -(macro:' #export (^ tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Macro-expanding patterns." ..\n - "## It's a special macro meant to be used with 'case'." ..\n - "(case (: (List Int) (list +1 +2 +3))" ..\n - " (^ (list x y z))" ..\n - " (#Some ($_ * x y z))" - __paragraph - " _" ..\n - " #None)"))]) - (case tokens - (#Cons [_ (#Form (#Cons pattern #Nil))] (#Cons body branches)) - (do meta_monad - [pattern+ (macro_expand_all pattern)] - (case pattern+ - (#Cons pattern' #Nil) - (wrap (list& pattern' body branches)) - - _ - (fail "^ can only expand to 1 pattern."))) - - _ - (fail "Wrong syntax for ^ macro"))) - -(macro:' #export (^or tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Or-patterns." ..\n - "## It's a special macro meant to be used with 'case'." ..\n - "(type: Weekday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday #Sunday)" - __paragraph - "(def: (weekend? day)" ..\n - " (-> Weekday Bit)" ..\n - " (case day" ..\n - " (^or #Saturday #Sunday)" ..\n - " #1" - __paragraph - " _" ..\n - " #0))"))]) - (case tokens - (^ (list& [_ (#Form patterns)] body branches)) - (case patterns - #Nil - (fail "^or cannot have 0 patterns") - - _ - (let' [pairs (|> patterns - (list\map (function' [pattern] (list pattern body))) - (list\join))] - (return (list\compose pairs branches)))) - _ - (fail "Wrong syntax for ^or"))) - -(def:' (identifier? code) - (-> Code Bit) - (case code - [_ (#Identifier _)] - #1 - - _ - #0)) - -(macro:' #export (let tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Creates local bindings." ..\n - "## Can (optionally) use pattern-matching macros when binding." ..\n - "(let [x (foo bar)" ..\n - " y (baz quux)]" ..\n - " (op x y))"))]) - (case tokens - (^ (list [_ (#Tuple bindings)] body)) - (if (multiple? 2 (list\size bindings)) - (|> bindings as_pairs list\reverse - (list\fold (: (-> [Code Code] Code Code) - (function' [lr body'] - (let' [[l r] lr] - (if (identifier? l) - (` ({(~ l) (~ body')} (~ r))) - (` (case (~ r) (~ l) (~ body'))))))) - body) - list - return) - (fail "let requires an even number of parts")) - - _ - (fail "Wrong syntax for let"))) - -(macro:' #export (function tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Syntax for creating functions." ..\n - "## Allows for giving the function itself a name, for the sake of recursion." ..\n - "(: (All [a b] (-> a b a))" ..\n - " (function (_ x y) x))" - __paragraph - "(: (All [a b] (-> a b a))" ..\n - " (function (const x y) x))"))]) - (case (: (Maybe [Text Code (List Code) Code]) - (case tokens - (^ (list [_ (#Form (list& [_ (#Identifier ["" name])] head tail))] body)) - (#Some name head tail body) - - _ - #None)) - (#Some g!name head tail body) - (let [g!blank (local_identifier$ "") - nest (: (-> Code (-> Code Code Code)) - (function' [g!name] - (function' [arg body'] - (if (identifier? arg) - (` ([(~ g!name) (~ arg)] (~ body'))) - (` ([(~ g!name) (~ g!blank)] - (.case (~ g!blank) (~ arg) (~ body'))))))))] - (return (list (nest (..local_identifier$ g!name) head - (list\fold (nest g!blank) body (list\reverse tail)))))) - - #None - (fail "Wrong syntax for function"))) - -(def:' (process_def_meta_value code) - (-> Code Code) - (case code - [_ (#Bit value)] - (meta_code ["lux" "Bit"] (bit$ value)) - - [_ (#Nat value)] - (meta_code ["lux" "Nat"] (nat$ value)) - - [_ (#Int value)] - (meta_code ["lux" "Int"] (int$ value)) - - [_ (#Rev value)] - (meta_code ["lux" "Rev"] (rev$ value)) - - [_ (#Frac value)] - (meta_code ["lux" "Frac"] (frac$ value)) - - [_ (#Text value)] - (meta_code ["lux" "Text"] (text$ value)) - - [_ (#Tag [prefix name])] - (meta_code ["lux" "Tag"] (` [(~ (text$ prefix)) (~ (text$ name))])) - - (^or [_ (#Form _)] [_ (#Identifier _)]) - code - - [_ (#Tuple xs)] - (|> xs - (list\map process_def_meta_value) - untemplate_list - (meta_code ["lux" "Tuple"])) - - [_ (#Record kvs)] - (|> kvs - (list\map (: (-> [Code Code] Code) - (function (_ [k v]) - (` [(~ (process_def_meta_value k)) - (~ (process_def_meta_value v))])))) - untemplate_list - (meta_code ["lux" "Record"])) - )) - -(def:' (process_def_meta kvs) - (-> (List [Code Code]) Code) - (untemplate_list (list\map (: (-> [Code Code] Code) - (function (_ [k v]) - (` [(~ (process_def_meta_value k)) - (~ (process_def_meta_value v))]))) - kvs))) - -(def:' (with_func_args args meta) - (-> (List Code) Code Code) - (case args - #Nil - meta - - _ - (` (#.Cons [[(~ location_code) (#.Tag ["lux" "func-args"])] - [(~ location_code) (#.Tuple (.list (~+ (list\map (function (_ arg) - (` [(~ location_code) (#.Text (~ (text$ (code\encode arg))))])) - args))))]] - (~ meta))))) - -(def:' (with_type_args args) - (-> (List Code) Code) - (` {#.type-args [(~+ (list\map (function (_ arg) (text$ (code\encode arg))) - args))]})) - -(def:' (export^ tokens) - (-> (List Code) [Bit (List Code)]) - (case tokens - (#Cons [_ (#Tag [_ "export"])] tokens') - [#1 tokens'] - - _ - [#0 tokens])) - -(def:' (export ?) - (-> Bit (List Code)) - (if ? - (list (' #export)) - (list))) - -(macro:' #export (def: tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Defines global constants/functions." ..\n - "(def: (rejoin_pair pair)" ..\n - " (-> [Code Code] (List Code))" ..\n - " (let [[left right] pair]" ..\n - " (list left right)))" - __paragraph - "(def: branching_exponent" ..\n - " Int" ..\n - " +5)"))]) - (let [[exported? tokens'] (export^ tokens) - parts (: (Maybe [Code (List Code) (Maybe Code) Code (List [Code Code])]) - (case tokens' - (^ (list [_ (#Form (#Cons name args))] [_ (#Record meta_kvs)] type body)) - (#Some [name args (#Some type) body meta_kvs]) - - (^ (list name [_ (#Record meta_kvs)] type body)) - (#Some [name #Nil (#Some type) body meta_kvs]) - - (^ (list [_ (#Form (#Cons name args))] [_ (#Record meta_kvs)] body)) - (#Some [name args #None body meta_kvs]) - - (^ (list name [_ (#Record meta_kvs)] body)) - (#Some [name #Nil #None body meta_kvs]) - - (^ (list [_ (#Form (#Cons name args))] type body)) - (#Some [name args (#Some type) body #Nil]) - - (^ (list name type body)) - (#Some [name #Nil (#Some type) body #Nil]) - - (^ (list [_ (#Form (#Cons name args))] body)) - (#Some [name args #None body #Nil]) - - (^ (list name body)) - (#Some [name #Nil #None body #Nil]) - - _ - #None))] - (case parts - (#Some name args ?type body meta) - (let [body (case args - #Nil - body - - _ - (` (function ((~ name) (~+ args)) (~ body)))) - body (case ?type - (#Some type) - (` (: (~ type) (~ body))) - - #None - body) - =meta (process_def_meta meta)] - (return (list (` ("lux def" (~ name) - (~ body) - [(~ location_code) - (#.Record (~ (with_func_args args =meta)))] - (~ (bit$ exported?))))))) - - #None - (fail "Wrong syntax for def:")))) - -(def: (meta_code_add addition meta) - (-> [Code Code] Code Code) - (case [addition meta] - [[name value] [location (#Record pairs)]] - [location (#Record (#Cons [name value] pairs))] - - _ - meta)) - -(def: (meta_code_merge addition base) - (-> Code Code Code) - (case addition - [location (#Record pairs)] - (list\fold meta_code_add base pairs) - - _ - base)) - -(macro:' #export (macro: tokens) - (list [(tag$ ["lux" "doc"]) - (text$ ($_ "lux text concat" - "## Macro-definition macro." ..\n - "(macro: #export (name_of tokens)" ..\n - " (case tokens" ..\n - " (^template []" ..\n - " [(^ (list [_ ( [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 [
] - [(macro: #export ( tokens) - {#.doc } - (case (list\reverse tokens) - (^ (list& last init)) - (return (list (list\fold (: (-> Code Code Code) - (function (_ pre post) (` ))) - last - init))) - - _ - (fail )))] - - [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 [ ] - [(def: ( type) - (-> Type (List Type)) - (case type - ( left right) - (list& left ( 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 [ ] - [(def: #export ( value) - (-> (I64 Any) ) - (:as 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 (_ ) (fold text\compose '''' (interpose '' '' (list\map int\encode ))))"))} - (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 (_ ) (fold text\compose '''' (interpose '' '' (list\map int\encode ))))"))} - (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 []" ..\n - " [( left right)" ..\n - " ( (beta_reduce env left) (beta_reduce env right))])" ..\n - " ([#.Sum] [#.Product])" - __paragraph - " (^template []" ..\n - " [( left right)" ..\n - " ( (beta_reduce env left) (beta_reduce env right))])" ..\n - " ([#.Function] [#.Apply])" - __paragraph - " (^template []" ..\n - " [( old_env def)" ..\n - " (case old_env" ..\n - " #.Nil" ..\n - " ( 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 [] - [[[_ _ column] ( _)] - column]) - ([#Bit] - [#Nat] - [#Int] - [#Rev] - [#Frac] - [#Text] - [#Identifier] - [#Tag]) - - (^template [] - [[[_ _ column] ( 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 [ ] - [(def: #export - {#.doc } - (All [s] (-> (I64 s) (I64 s))) - (|>> ( 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 [ ] - [[new_location ( value)] - (let [as_text ( 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 [ ] - [[group_location ( 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) ""] - ( parts))] - [(delim_update_location group_location') - ($_ text\compose (location_padding baseline prev_location group_location) - - parts_text - )])]) - ([#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 [] - [( left right) - (` ( (~ (type_to_code left)) (~ (type_to_code right))))]) - ([#.Sum] [#.Product] - [#.Function] - [#.Apply]) - - (^template [] - [( id) - (` ( (~ (nat$ id))))]) - ([#.Parameter] [#.Var] [#.Ex]) - - (^template [] - [( env type) - (let [env' (untemplate_list (list\map type_to_code env))] - (` ( (~ 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 [] - [[location ( elems)] - (do maybe_monad - [placements (monad\map maybe_monad (place_tokens label tokens) elems)] - (wrap (list [location ( (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 - [ (template [ ] - [(compare (\ Code/encode encode ))] - - [(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 ))))} - (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 [] - [(#Named ["lux" ] _) - 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 [ ] - [(#Named ["lux" ] _) - (wrap ( (:as 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 [] - [[meta ( parts)] - (do meta_monad - [=parts (monad\map meta_monad anti_quote parts)] - (wrap [meta ( =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) - "=>" - ["lux" "doc"])} - (case tokens - (^template [] - [(^ (list [_ ( [prefix name])])) - (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))]) - ([#Identifier] [#Tag]) - - _ - (fail (..wrong_syntax_error ["lux" "name_of"])))) - -(def: (get_scope_type_vars state) - (Meta (List Nat)) - (case state - {#info info #source source #current_module _ #modules modules - #scopes scopes #type_context types #host host - #seed seed #expected expected #location location #extensions extensions - #scope_type_vars scope_type_vars} - (#Right state scope_type_vars) - )) - -(def: (list_at idx xs) - (All [a] (-> Nat (List a) (Maybe a))) - (case xs - #Nil - #None - - (#Cons x xs') - (if ("lux i64 =" 0 idx) - (#Some x) - (list_at (dec idx) xs')))) - -(macro: #export ($ tokens) - {#.doc (doc "Allows you to refer to the type-variables in a polymorphic function's type, by their index." - "In the example below, 0 corresponds to the 'a' variable." - (def: #export (from_list list) - (All [a] (-> (List a) (Row a))) - (list\fold add - (: (Row ($ 0)) - empty) - list)))} - (case tokens - (^ (list [_ (#Nat idx)])) - (do meta_monad - [stvs get_scope_type_vars] - (case (list_at idx (list\reverse stvs)) - (#Some var_id) - (wrap (list (` (#Ex (~ (nat$ var_id)))))) - - #None - (fail (text\compose "Indexed-type does not exist: " (nat\encode idx))))) - - _ - (fail (..wrong_syntax_error (name_of ..$))))) - -(def: #export (is? reference sample) - {#.doc (doc "Tests whether the 2 values are identical (not just 'equal')." - "This one should succeed:" - (let [value +5] - (is? value value)) - - "This one should fail:" - (is? +5 (+ +2 +3)))} - (All [a] (-> a a Bit)) - ("lux is" reference sample)) - -(macro: #export (^@ tokens) - {#.doc (doc "Allows you to simultaneously bind and de-structure a value." - (def: (hash (^@ set [Hash _])) - (list\fold (function (_ elem acc) (+ (\ Hash 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 ["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 [ ] - [(def: ( xy) - (All [a b] (-> [a b] )) - (let [[x y] xy] - ))] - - [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 [] - [[ann ( parts)] - (do meta_monad - [=parts (monad\map meta_monad label_code parts)] - (wrap [(list\fold list\compose (list) (list\map left =parts)) - [ann ( (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 [ ] - [(def: ( 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) ( (~ (untemplate_list& spliced =inits)))]))) - - _ - (do meta_monad - [=elems (monad\map meta_monad untemplate_pattern elems)] - (wrap (` [(~ g!meta) ( (~ (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 [ ] - [[_ ( value)] - (wrap (` [(~ g!meta) ( (~ ( 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 [ ] - [[_ ( elems)] - ( 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 [ ] - [(def: #export #0) - (def: #export #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))))) -- cgit v1.2.3