aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux.lux
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux.lux5953
1 files changed, 0 insertions, 5953 deletions
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 [<name> <diff>]" ..\n
- " " "[(def: #export <name> (-> Int Int) (+ <diff>))]" __paragraph
- " " "[inc +1]" ..\n
- " " "[dec -1]"))])
- ({(#Cons [[_ (#Tuple bindings)] (#Cons [[_ (#Tuple templates)] data])])
- ({[(#Some bindings') (#Some data')]
- (let' [apply ("lux type check" (-> RepEnv ($' List Code))
- (function' [env] (list\map (apply_template env) templates)))
- num_bindings (list\size bindings')]
- (if (every? (function' [size] ("lux i64 =" num_bindings size))
- (list\map list\size data'))
- (|> data'
- (list\map (compose apply (make_env bindings')))
- list\join
- return)
- (fail "Irregular arguments tuples for template.")))
-
- _
- (fail "Wrong syntax for template")}
- [(monad\map maybe_monad get_short bindings)
- (monad\map maybe_monad tuple->list data)])
-
- _
- (fail "Wrong syntax for template")}
- tokens))
-
-(def:''' (n// param subject)
- (list)
- (-> Nat Nat Nat)
- (if ("lux i64 <" +0 ("lux type as" Int param))
- (if (n/< param subject)
- 0
- 1)
- (let' [quotient (|> subject
- ("lux i64 right-shift" 1)
- ("lux i64 /" ("lux type as" Int param))
- ("lux i64 left-shift" 1))
- flat ("lux i64 *"
- ("lux type as" Int param)
- ("lux type as" Int quotient))
- remainder ("lux i64 -" flat subject)]
- (if (n/< param remainder)
- quotient
- ("lux i64 +" 1 quotient)))))
-
-(def:''' (n/% param subject)
- (list)
- (-> Nat Nat Nat)
- (let' [flat ("lux i64 *"
- ("lux type as" Int param)
- ("lux type as" Int (n// param subject)))]
- ("lux i64 -" flat subject)))
-
-(def:''' (n/min left right)
- (list)
- (-> Nat Nat Nat)
- (if (n/< right left)
- left
- right))
-
-(def:''' (bit\encode x)
- #Nil
- (-> Bit Text)
- (if x "#1" "#0"))
-
-(def:''' (digit::format digit)
- #Nil
- (-> Nat Text)
- ({0 "0"
- 1 "1" 2 "2" 3 "3"
- 4 "4" 5 "5" 6 "6"
- 7 "7" 8 "8" 9 "9"
- _ ("lux io error" "@digit::format Undefined behavior.")}
- digit))
-
-(def:''' (nat\encode value)
- #Nil
- (-> Nat Text)
- ({0
- "0"
-
- _
- (let' [loop ("lux type check" (-> Nat Text Text)
- (function' recur [input output]
- (if ("lux i64 =" 0 input)
- output
- (recur (n// 10 input)
- (text\compose (|> input (n/% 10) digit::format)
- output)))))]
- (loop value ""))}
- value))
-
-(def:''' (int\abs value)
- #Nil
- (-> Int Int)
- (if ("lux i64 <" +0 value)
- ("lux i64 *" -1 value)
- value))
-
-(def:''' (int\encode value)
- #Nil
- (-> Int Text)
- (if ("lux i64 =" +0 value)
- "+0"
- (let' [sign (if ("lux i64 <" value +0)
- "+"
- "-")]
- (("lux type check" (-> Int Text Text)
- (function' recur [input output]
- (if ("lux i64 =" +0 input)
- (text\compose sign output)
- (recur ("lux i64 /" +10 input)
- (text\compose (|> input ("lux i64 %" +10) ("lux type as" Nat) digit::format)
- output)))))
- (|> value ("lux i64 /" +10) int\abs)
- (|> value ("lux i64 %" +10) int\abs ("lux type as" Nat) digit::format)))))
-
-(def:''' (frac\encode x)
- #Nil
- (-> Frac Text)
- ("lux f64 encode" x))
-
-(def:''' (multiple? div n)
- #Nil
- (-> Nat Nat Bit)
- (|> n (n/% div) ("lux i64 =" 0)))
-
-(def:''' #export (not x)
- (list [(tag$ ["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 [<name> <type> <value>]
- [(def:''' (<name> xy)
- #Nil
- (All [a b] (-> (& a b) <type>))
- (let' [[x y] xy] <value>))]
-
- [first a x]
- [second b y])
-
-(def:''' (unfold_type_def type_codes)
- #Nil
- (-> ($' List Code) ($' Meta (& Code ($' Maybe ($' List Text)))))
- ({(#Cons [_ (#Record pairs)] #Nil)
- (do meta_monad
- [members (monad\map meta_monad
- (: (-> [Code Code] (Meta [Text Code]))
- (function' [pair]
- ({[[_ (#Tag "" member_name)] member_type]
- (return [member_name member_type])
-
- _
- (fail "Wrong syntax for variant case.")}
- pair)))
- pairs)]
- (return [(` (& (~+ (list\map second members))))
- (#Some (list\map first members))]))
-
- (#Cons type #Nil)
- ({[_ (#Tag "" member_name)]
- (return [(` .Any) (#Some (list member_name))])
-
- [_ (#Form (#Cons [_ (#Tag "" member_name)] member_types))]
- (return [(` (& (~+ member_types))) (#Some (list member_name))])
-
- _
- (return [type #None])}
- type)
-
- (#Cons case cases)
- (do meta_monad
- [members (monad\map meta_monad
- (: (-> Code (Meta [Text Code]))
- (function' [case]
- ({[_ (#Tag "" member_name)]
- (return [member_name (` .Any)])
-
- [_ (#Form (#Cons [_ (#Tag "" member_name)] (#Cons member_type #Nil)))]
- (return [member_name member_type])
-
- [_ (#Form (#Cons [_ (#Tag "" member_name)] member_types))]
- (return [member_name (` (& (~+ member_types)))])
-
- _
- (fail "Wrong syntax for variant case.")}
- case)))
- (list& case cases))]
- (return [(` (| (~+ (list\map second members))))
- (#Some (list\map first members))]))
-
- _
- (fail "Improper type-definition syntax")}
- type_codes))
-
-(def:''' (gensym prefix state)
- #Nil
- (-> Text ($' Meta Code))
- ({{#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected
- #location location #extensions extensions
- #scope_type_vars scope_type_vars}
- (#Right {#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed ("lux i64 +" 1 seed) #expected expected
- #location location #extensions extensions
- #scope_type_vars scope_type_vars}
- (local_identifier$ ($_ text\compose "__gensym__" prefix (nat\encode seed))))}
- state))
-
-(macro:' #export (Rec tokens)
- (list [(tag$ ["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 [<tag>]" ..\n
- " [(^ (list [_ (<tag> [prefix name])]))" ..\n
- " (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))])" ..\n
- " ([#Identifier] [#Tag])"
- __paragraph
- " _" ..\n
- " (fail ''Wrong syntax for name_of'')))"))])
- (let [[exported? tokens] (export^ tokens)
- name+args+meta+body?? (: (Maybe [Name (List Code) (List [Code Code]) Code])
- (case tokens
- (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] body))
- (#Some [name args (list) body])
-
- (^ (list [_ (#Identifier name)] body))
- (#Some [name #Nil (list) body])
-
- (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] [_ (#Record meta_rec_parts)] body))
- (#Some [name args meta_rec_parts body])
-
- (^ (list [_ (#Identifier name)] [_ (#Record meta_rec_parts)] body))
- (#Some [name #Nil meta_rec_parts body])
-
- _
- #None))]
- (case name+args+meta+body??
- (#Some [name args meta body])
- (let [name (identifier$ name)
- body (case args
- #Nil
- body
-
- _
- (` ("lux macro"
- (function ((~ name) (~+ args)) (~ body)))))
- =meta (process_def_meta meta)]
- (return (list (` ("lux def" (~ name)
- (~ body)
- [(~ location_code)
- (#Record (~ =meta))]
- (~ (bit$ exported?)))))))
-
- #None
- (fail "Wrong syntax for macro:"))))
-
-(macro: #export (interface: tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Definition of signatures ala ML." ..\n
- "(interface: #export (Ord a)" ..\n
- " (: (Equivalence a)" ..\n
- " eq)" ..\n
- " (: (-> a a Bit)" ..\n
- " <)" ..\n
- " (: (-> a a Bit)" ..\n
- " <=)" ..\n
- " (: (-> a a Bit)" ..\n
- " >)" ..\n
- " (: (-> a a Bit)" ..\n
- " >=))"))}
- (let [[exported? tokens'] (export^ tokens)
- ?parts (: (Maybe [Name (List Code) Code (List Code)])
- (case tokens'
- (^ (list& [_ (#Form (list& [_ (#Identifier name)] args))] [meta_rec_location (#Record meta_rec_parts)] sigs))
- (#Some name args [meta_rec_location (#Record meta_rec_parts)] sigs)
-
- (^ (list& [_ (#Identifier name)] [meta_rec_location (#Record meta_rec_parts)] sigs))
- (#Some name #Nil [meta_rec_location (#Record meta_rec_parts)] sigs)
-
- (^ (list& [_ (#Form (list& [_ (#Identifier name)] args))] sigs))
- (#Some name args (` {}) sigs)
-
- (^ (list& [_ (#Identifier name)] sigs))
- (#Some name #Nil (` {}) sigs)
-
- _
- #None))]
- (case ?parts
- (#Some name args meta sigs)
- (do meta_monad
- [name+ (normalize name)
- sigs' (monad\map meta_monad macro_expand sigs)
- members (: (Meta (List [Text Code]))
- (monad\map meta_monad
- (: (-> Code (Meta [Text Code]))
- (function (_ token)
- (case token
- (^ [_ (#Form (list [_ (#Text "lux type check")] type [_ (#Identifier ["" name])]))])
- (wrap [name type])
-
- _
- (fail "Signatures require typed members!"))))
- (list\join sigs')))
- #let [[_module _name] name+
- def_name (identifier$ name)
- sig_type (record$ (list\map (: (-> [Text Code] [Code Code])
- (function (_ [m_name m_type])
- [(local_tag$ m_name) m_type]))
- members))
- sig_meta (meta_code_merge (` {#.sig? #1})
- meta)
- usage (case args
- #Nil
- def_name
-
- _
- (` ((~ def_name) (~+ args))))]]
- (return (list (` (..type: (~+ (export exported?)) (~ usage) (~ sig_meta) (~ sig_type))))))
-
- #None
- (fail "Wrong syntax for interface:"))))
-
-(def: (find f xs)
- (All [a b]
- (-> (-> a (Maybe b)) (List a) (Maybe b)))
- (case xs
- #Nil
- #None
-
- (#Cons x xs')
- (case (f x)
- #None
- (find f xs')
-
- (#Some y)
- (#Some y))))
-
-(template [<name> <form> <message> <doc_msg>]
- [(macro: #export (<name> tokens)
- {#.doc <doc_msg>}
- (case (list\reverse tokens)
- (^ (list& last init))
- (return (list (list\fold (: (-> Code Code Code)
- (function (_ pre post) (` <form>)))
- last
- init)))
-
- _
- (fail <message>)))]
-
- [and (if (~ pre) (~ post) #0) "'and' requires >=1 clauses." "Short-circuiting 'and': (and #1 #0 #1) ## => #0"]
- [or (if (~ pre) #1 (~ post)) "'or' requires >=1 clauses." "Short-circuiting 'or': (or #1 #0 #1) ## => #1"])
-
-(def: (index_of part text)
- (-> Text Text (Maybe Nat))
- ("lux text index" 0 part text))
-
-(def: #export (error! message)
- {#.doc (text$ ($_ "lux text concat"
- "## Causes an error, with the given error message." ..\n
- "(error! ''OH NO!'')"))}
- (-> Text Nothing)
- ("lux io error" message))
-
-(macro: (default tokens state)
- {#.doc (text$ ($_ "lux text concat"
- "## Allows you to provide a default value that will be used" ..\n
- "## if a (Maybe x) value turns out to be #.None."
- __paragraph
- "(default +20 (#.Some +10)) ## => +10"
- __paragraph
- "(default +20 #.None) ## => +20"))}
- (case tokens
- (^ (list else maybe))
- (let [g!temp (: Code [dummy_location (#Identifier ["" ""])])
- code (` (case (~ maybe)
- (#.Some (~ g!temp))
- (~ g!temp)
-
- #.None
- (~ else)))]
- (#Right [state (list code)]))
-
- _
- (#Left "Wrong syntax for default")))
-
-(def: (text\split_all_with splitter input)
- (-> Text Text (List Text))
- (case (..index_of splitter input)
- #None
- (list input)
-
- (#Some idx)
- (list& ("lux text clip" 0 idx input)
- (text\split_all_with splitter
- (let [after_offset ("lux i64 +" 1 idx)
- after_length ("lux i64 -"
- after_offset
- ("lux text size" input))]
- ("lux text clip" after_offset after_length input))))))
-
-(def: (nth idx xs)
- (All [a]
- (-> Nat (List a) (Maybe a)))
- (case xs
- #Nil
- #None
-
- (#Cons x xs')
- (if ("lux i64 =" 0 idx)
- (#Some x)
- (nth ("lux i64 -" 1 idx) xs')
- )))
-
-(def: (beta_reduce env type)
- (-> (List Type) Type Type)
- (case type
- (#Sum left right)
- (#Sum (beta_reduce env left) (beta_reduce env right))
-
- (#Product left right)
- (#Product (beta_reduce env left) (beta_reduce env right))
-
- (#Apply arg func)
- (#Apply (beta_reduce env arg) (beta_reduce env func))
-
- (#UnivQ ?local_env ?local_def)
- (case ?local_env
- #Nil
- (#UnivQ env ?local_def)
-
- _
- type)
-
- (#ExQ ?local_env ?local_def)
- (case ?local_env
- #Nil
- (#ExQ env ?local_def)
-
- _
- type)
-
- (#Function ?input ?output)
- (#Function (beta_reduce env ?input) (beta_reduce env ?output))
-
- (#Parameter idx)
- (case (nth idx env)
- (#Some parameter)
- parameter
-
- _
- type)
-
- (#Named name type)
- (beta_reduce env type)
-
- _
- type
- ))
-
-(def: (apply_type type_fn param)
- (-> Type Type (Maybe Type))
- (case type_fn
- (#UnivQ env body)
- (#Some (beta_reduce (list& type_fn param env) body))
-
- (#ExQ env body)
- (#Some (beta_reduce (list& type_fn param env) body))
-
- (#Apply A F)
- (do maybe_monad
- [type_fn* (apply_type F A)]
- (apply_type type_fn* param))
-
- (#Named name type)
- (apply_type type param)
-
- _
- #None))
-
-(template [<name> <tag>]
- [(def: (<name> type)
- (-> Type (List Type))
- (case type
- (<tag> left right)
- (list& left (<name> right))
-
- _
- (list type)))]
-
- [flatten_variant #Sum]
- [flatten_tuple #Product]
- [flatten_lambda #Function]
- )
-
-(def: (flatten_app type)
- (-> Type [Type (List Type)])
- (case type
- (#Apply head func')
- (let [[func tail] (flatten_app func')]
- [func (#Cons head tail)])
-
- _
- [type (list)]))
-
-(def: (resolve_struct_type type)
- (-> Type (Maybe (List Type)))
- (case type
- (#Product _)
- (#Some (flatten_tuple type))
-
- (#Apply arg func)
- (do maybe_monad
- [output (apply_type func arg)]
- (resolve_struct_type output))
-
- (#UnivQ _ body)
- (resolve_struct_type body)
-
- (#ExQ _ body)
- (resolve_struct_type body)
-
- (#Named name type)
- (resolve_struct_type type)
-
- (#Sum _)
- #None
-
- _
- (#Some (list type))))
-
-(def: (find_module name)
- (-> Text (Meta Module))
- (function (_ state)
- (let [{#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars} state]
- (case (get name modules)
- (#Some module)
- (#Right state module)
-
- _
- (#Left ($_ text\compose "Unknown module: " name))))))
-
-(def: get_current_module
- (Meta Module)
- (do meta_monad
- [module_name current_module_name]
- (find_module module_name)))
-
-(def: (resolve_tag [module name])
- (-> Name (Meta [Nat (List Name) Bit Type]))
- (do meta_monad
- [=module (find_module module)
- #let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags_table #types types #module_annotations _ #module_state _} =module]]
- (case (get name tags_table)
- (#Some output)
- (return output)
-
- _
- (fail (text\compose "Unknown tag: " (name\encode [module name]))))))
-
-(def: (resolve_type_tags type)
- (-> Type (Meta (Maybe [(List Name) (List Type)])))
- (case type
- (#Apply arg func)
- (resolve_type_tags func)
-
- (#UnivQ env body)
- (resolve_type_tags body)
-
- (#ExQ env body)
- (resolve_type_tags body)
-
- (#Named [module name] unnamed)
- (do meta_monad
- [=module (find_module module)
- #let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags #types types #module_annotations _ #module_state _} =module]]
- (case (get name types)
- (#Some [tags exported? (#Named _ _type)])
- (case (resolve_struct_type _type)
- (#Some members)
- (return (#Some [tags members]))
-
- _
- (return #None))
-
- _
- (resolve_type_tags unnamed)))
-
- _
- (return #None)))
-
-(def: get_expected_type
- (Meta Type)
- (function (_ state)
- (let [{#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars} state]
- (case expected
- (#Some type)
- (#Right state type)
-
- #None
- (#Left "Not expecting any type.")))))
-
-(macro: #export (implementation tokens)
- {#.doc "Not meant to be used directly. Prefer 'implementation:'."}
- (do meta_monad
- [tokens' (monad\map meta_monad macro_expand tokens)
- struct_type get_expected_type
- tags+type (resolve_type_tags struct_type)
- tags (: (Meta (List Name))
- (case tags+type
- (#Some [tags _])
- (return tags)
-
- _
- (fail "No tags available for type.")))
- #let [tag_mappings (: (List [Text Code])
- (list\map (function (_ tag) [(second tag) (tag$ tag)])
- tags))]
- members (monad\map meta_monad
- (: (-> Code (Meta [Code Code]))
- (function (_ token)
- (case token
- (^ [_ (#Form (list [_ (#Text "lux def")] [_ (#Identifier "" tag_name)] value meta [_ (#Bit #0)]))])
- (case (get tag_name tag_mappings)
- (#Some tag)
- (wrap [tag value])
-
- _
- (fail (text\compose "Unknown implementation member: " tag_name)))
-
- _
- (fail "Invalid implementation member."))))
- (list\join tokens'))]
- (wrap (list (record$ members)))))
-
-(def: (text\join_with separator parts)
- (-> Text (List Text) Text)
- (case parts
- #Nil
- ""
-
- (#Cons head tail)
- (list\fold (function (_ right left)
- ($_ text\compose left separator right))
- head
- tail)))
-
-(macro: #export (implementation: tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Definition of structures ala ML." ..\n
- "(implementation: #export order (Order Int)" ..\n
- " (def: &equivalence equivalence)" ..\n
- " (def: (< test subject)" ..\n
- " (< test subject))" ..\n
- " (def: (<= test subject)" ..\n
- " (or (< test subject)" ..\n
- " (= test subject)))" ..\n
- " (def: (> test subject)" ..\n
- " (> test subject))" ..\n
- " (def: (>= test subject)" ..\n
- " (or (> test subject)" ..\n
- " (= test subject))))"))}
- (let [[exported? tokens'] (export^ tokens)
- ?parts (: (Maybe [Code (List Code) Code Code (List Code)])
- (case tokens'
- (^ (list& [_ (#Form (list& name args))] [meta_rec_location (#Record meta_rec_parts)] type definitions))
- (#Some name args type [meta_rec_location (#Record meta_rec_parts)] definitions)
-
- (^ (list& name [meta_rec_location (#Record meta_rec_parts)] type definitions))
- (#Some name #Nil type [meta_rec_location (#Record meta_rec_parts)] definitions)
-
- (^ (list& [_ (#Form (list& name args))] type definitions))
- (#Some name args type (` {}) definitions)
-
- (^ (list& name type definitions))
- (#Some name #Nil type (` {}) definitions)
-
- _
- #None))]
- (case ?parts
- (#Some [name args type meta definitions])
- (let [usage (case args
- #Nil
- name
-
- _
- (` ((~ name) (~+ args))))]
- (return (list (` (..def: (~+ (export exported?)) (~ usage)
- (~ (meta_code_merge (` {#.implementation? #1})
- meta))
- (~ type)
- (implementation (~+ definitions)))))))
-
- #None
- (fail "Wrong syntax for implementation:"))))
-
-(def: (function\identity x) (All [a] (-> a a)) x)
-
-(macro: #export (type: tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## The type-definition macro." ..\n
- "(type: (List a) #Nil (#Cons a (List a)))"))}
- (let [[exported? tokens'] (export^ tokens)
- [rec? tokens'] (case tokens'
- (#Cons [_ (#Tag [_ "rec"])] tokens')
- [#1 tokens']
-
- _
- [#0 tokens'])
- parts (: (Maybe [Text (List Code) (List [Code Code]) (List Code)])
- (case tokens'
- (^ (list [_ (#Identifier "" name)] [meta_location (#Record meta_parts)] [type_location (#Record type_parts)]))
- (#Some [name #Nil meta_parts (list [type_location (#Record type_parts)])])
-
- (^ (list& [_ (#Identifier "" name)] [meta_location (#Record meta_parts)] type_code1 type_codes))
- (#Some [name #Nil meta_parts (#Cons type_code1 type_codes)])
-
- (^ (list& [_ (#Identifier "" name)] type_codes))
- (#Some [name #Nil (list) type_codes])
-
- (^ (list [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta_location (#Record meta_parts)] [type_location (#Record type_parts)]))
- (#Some [name args meta_parts (list [type_location (#Record type_parts)])])
-
- (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta_location (#Record meta_parts)] type_code1 type_codes))
- (#Some [name args meta_parts (#Cons type_code1 type_codes)])
-
- (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] type_codes))
- (#Some [name args (list) type_codes])
-
- _
- #None))]
- (case parts
- (#Some name args meta type_codes)
- (do meta_monad
- [type+tags?? (unfold_type_def type_codes)
- module_name current_module_name]
- (let [type_name (local_identifier$ name)
- [type tags??] type+tags??
- type' (: (Maybe Code)
- (if rec?
- (if (empty? args)
- (let [g!param (local_identifier$ "")
- prime_name (local_identifier$ name)
- type+ (replace_syntax (list [name (` ((~ prime_name) .Nothing))]) type)]
- (#Some (` ((All (~ prime_name) [(~ g!param)] (~ type+))
- .Nothing))))
- #None)
- (case args
- #Nil
- (#Some type)
-
- _
- (#Some (` (.All (~ type_name) [(~+ args)] (~ type)))))))
- total_meta (let [meta (process_def_meta meta)
- meta (if rec?
- (` (#.Cons (~ (flag_meta "type-rec?")) (~ meta)))
- meta)]
- (` [(~ location_code)
- (#.Record (~ meta))]))]
- (case type'
- (#Some type'')
- (let [typeC (` (#.Named [(~ (text$ module_name))
- (~ (text$ name))]
- (.type (~ type''))))]
- (return (list (case tags??
- (#Some tags)
- (` ("lux def type tagged" (~ type_name)
- (~ typeC)
- (~ total_meta)
- [(~+ (list\map text$ tags))]
- (~ (bit$ exported?))))
-
- _
- (` ("lux def" (~ type_name)
- ("lux type check type"
- (~ typeC))
- (~ total_meta)
- (~ (bit$ exported?))))))))
-
- #None
- (fail "Wrong syntax for type:"))))
-
- #None
- (fail "Wrong syntax for type:"))
- ))
-
-(template [<name> <to>]
- [(def: #export (<name> value)
- (-> (I64 Any) <to>)
- (:as <to> value))]
-
- [i64 I64]
- [nat Nat]
- [int Int]
- [rev Rev]
- )
-
-(type: Referrals
- #All
- (#Only (List Text))
- (#Exclude (List Text))
- #Ignore
- #Nothing)
-
-(type: Openings
- [Text (List Text)])
-
-(type: Refer
- {#refer_defs Referrals
- #refer_open (List Openings)})
-
-(type: Importation
- {#import_name Text
- #import_alias (Maybe Text)
- #import_refer Refer})
-
-(def: (extract_defs defs)
- (-> (List Code) (Meta (List Text)))
- (monad\map meta_monad
- (: (-> Code (Meta Text))
- (function (_ def)
- (case def
- [_ (#Identifier ["" name])]
- (return name)
-
- _
- (fail "#only/#+ and #exclude/#- require identifiers."))))
- defs))
-
-(def: (parse_referrals tokens)
- (-> (List Code) (Meta [Referrals (List Code)]))
- (case tokens
- (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "+"])] defs))] tokens'))
- (^ (list& [_ (#Form (list& [_ (#Tag ["" "only"])] defs))] tokens')))
- (do meta_monad
- [defs' (extract_defs defs)]
- (wrap [(#Only defs') tokens']))
-
- (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "-"])] defs))] tokens'))
- (^ (list& [_ (#Form (list& [_ (#Tag ["" "exclude"])] defs))] tokens')))
- (do meta_monad
- [defs' (extract_defs defs)]
- (wrap [(#Exclude defs') tokens']))
-
- (^or (^ (list& [_ (#Tag ["" "*"])] tokens'))
- (^ (list& [_ (#Tag ["" "all"])] tokens')))
- (return [#All tokens'])
-
- (^or (^ (list& [_ (#Tag ["" "_"])] tokens'))
- (^ (list& [_ (#Tag ["" "nothing"])] tokens')))
- (return [#Ignore tokens'])
-
- _
- (return [#Nothing tokens])))
-
-(def: (parse_openings parts)
- (-> (List Code) (Meta [(List Openings) (List Code)]))
- (case parts
- #.Nil
- (return [#.Nil #.Nil])
-
- (^ (list& [_ (#Form (list& [_ (#Text prefix)] structs))] parts'))
- (do meta_monad
- [structs' (monad\map meta_monad
- (function (_ struct)
- (case struct
- [_ (#Identifier ["" struct_name])]
- (return struct_name)
-
- _
- (fail "Expected all implementations of opening form to be identifiers.")))
- structs)
- next+remainder (parse_openings parts')]
- (let [[next remainder] next+remainder]
- (return [(#.Cons [prefix structs'] next)
- remainder])))
-
- _
- (return [#.Nil parts])))
-
-(def: (text\split! at x)
- (-> Nat Text [Text Text])
- [("lux text clip" 0 at x)
- ("lux text clip" at (|> x "lux text size" ("lux i64 -" at)) x)])
-
-(def: (text\split_with token sample)
- (-> Text Text (Maybe [Text Text]))
- (do ..maybe_monad
- [index (..index_of token sample)
- #let [[pre post'] (text\split! index sample)
- [_ post] (text\split! ("lux text size" token) post')]]
- (wrap [pre post])))
-
-(def: (replace_all pattern replacement template)
- (-> Text Text Text Text)
- ((: (-> Text Text Text)
- (function (recur left right)
- (case (..text\split_with pattern right)
- (#.Some [pre post])
- (recur ($_ "lux text concat" left pre replacement) post)
-
- #.None
- ("lux text concat" left right))))
- "" template))
-
-(def: contextual_reference "#")
-(def: self_reference ".")
-
-(def: (de_alias context self aliased)
- (-> Text Text Text Text)
- (|> aliased
- (replace_all ..self_reference self)
- (replace_all ..contextual_reference context)))
-
-(def: #export module_separator
- "/")
-
-(def: parallel_hierarchy_sigil
- "\")
-
-(def: (normalize_parallel_path' hierarchy root)
- (-> Text Text Text)
- (case [(text\split_with ..module_separator hierarchy)
- (text\split_with ..parallel_hierarchy_sigil root)]
- [(#.Some [_ hierarchy'])
- (#.Some ["" root'])]
- (normalize_parallel_path' hierarchy' root')
-
- _
- (case root
- "" hierarchy
- _ ($_ text\compose root ..module_separator hierarchy))))
-
-(def: (normalize_parallel_path hierarchy root)
- (-> Text Text (Maybe Text))
- (case (text\split_with ..parallel_hierarchy_sigil root)
- (#.Some ["" root'])
- (#.Some (normalize_parallel_path' hierarchy root'))
-
- _
- #.None))
-
-(def: (count_relatives relatives input)
- (-> Nat Text Nat)
- (case ("lux text index" relatives ..module_separator input)
- #None
- relatives
-
- (#Some found)
- (if ("lux i64 =" relatives found)
- (count_relatives ("lux i64 +" 1 relatives) input)
- relatives)))
-
-(def: (list\take amount list)
- (All [a] (-> Nat (List a) (List a)))
- (case [amount list]
- (^or [0 _] [_ #Nil])
- #Nil
-
- [_ (#Cons head tail)]
- (#Cons head (list\take ("lux i64 -" 1 amount) tail))))
-
-(def: (list\drop amount list)
- (All [a] (-> Nat (List a) (List a)))
- (case [amount list]
- (^or [0 _] [_ #Nil])
- list
-
- [_ (#Cons _ tail)]
- (list\drop ("lux i64 -" 1 amount) tail)))
-
-(def: (clean_module nested? relative_root module)
- (-> Bit Text Text (Meta Text))
- (case (count_relatives 0 module)
- 0
- (return (if nested?
- ($_ "lux text concat" relative_root ..module_separator module)
- module))
-
- relatives
- (let [parts (text\split_all_with ..module_separator relative_root)
- jumps ("lux i64 -" 1 relatives)]
- (if (n/< (list\size parts) jumps)
- (let [prefix (|> parts
- list\reverse
- (list\drop jumps)
- list\reverse
- (interpose ..module_separator)
- (text\join_with ""))
- clean ("lux text clip" relatives (|> module "lux text size" ("lux i64 -" relatives)) module)
- output (case ("lux text size" clean)
- 0 prefix
- _ ($_ text\compose prefix ..module_separator clean))]
- (return output))
- (fail ($_ "lux text concat"
- "Cannot climb the module hierarchy..." ..\n
- "Importing module: " module ..\n
- " Relative Root: " relative_root ..\n))))))
-
-(def: (alter_domain alteration domain import)
- (-> Nat Text Importation Importation)
- (let [[import_name import_alias import_refer] import
- original (text\split_all_with ..module_separator import_name)
- truncated (list\drop (.nat alteration) original)
- parallel (case domain
- ""
- truncated
-
- _
- (list& domain truncated))]
- {#import_name (text\join_with ..module_separator parallel)
- #import_alias import_alias
- #import_refer import_refer}))
-
-(def: (parse_imports nested? relative_root context_alias imports)
- (-> Bit Text Text (List Code) (Meta (List Importation)))
- (do meta_monad
- [imports' (monad\map meta_monad
- (: (-> Code (Meta (List Importation)))
- (function (_ token)
- (case token
- ## Simple
- [_ (#Identifier ["" m_name])]
- (do meta_monad
- [m_name (clean_module nested? relative_root m_name)]
- (wrap (list {#import_name m_name
- #import_alias #None
- #import_refer {#refer_defs #All
- #refer_open (list)}})))
-
- ## Nested
- (^ [_ (#Tuple (list& [_ (#Identifier ["" m_name])] extra))])
- (do meta_monad
- [import_name (case (normalize_parallel_path relative_root m_name)
- (#.Some parallel_path)
- (wrap parallel_path)
-
- #.None
- (clean_module nested? relative_root m_name))
- referral+extra (parse_referrals extra)
- #let [[referral extra] referral+extra]
- openings+extra (parse_openings extra)
- #let [[openings extra] openings+extra]
- sub_imports (parse_imports #1 import_name context_alias extra)]
- (wrap (case [referral openings]
- [#Nothing #Nil]
- sub_imports
-
- _
- (list& {#import_name import_name
- #import_alias #None
- #import_refer {#refer_defs referral
- #refer_open openings}}
- sub_imports))))
-
- (^ [_ (#Tuple (list& [_ (#Text alias)] [_ (#Identifier ["" m_name])] extra))])
- (do meta_monad
- [import_name (case (normalize_parallel_path relative_root m_name)
- (#.Some parallel_path)
- (wrap parallel_path)
-
- #.None
- (clean_module nested? relative_root m_name))
- referral+extra (parse_referrals extra)
- #let [[referral extra] referral+extra]
- openings+extra (parse_openings extra)
- #let [[openings extra] openings+extra
- de_aliased (de_alias context_alias m_name alias)]
- sub_imports (parse_imports #1 import_name de_aliased extra)]
- (wrap (case [referral openings]
- [#Ignore #Nil]
- sub_imports
-
- _
- (list& {#import_name import_name
- #import_alias (#Some de_aliased)
- #import_refer {#refer_defs referral
- #refer_open openings}}
- sub_imports))))
-
- ## Unrecognized syntax.
- _
- (do meta_monad
- [current_module current_module_name]
- (fail ($_ text\compose
- "Wrong syntax for import @ " current_module
- ..\n (code\encode token)))))))
- imports)]
- (wrap (list\join imports'))))
-
-(def: (exported_definitions module state)
- (-> Text (Meta (List Text)))
- (let [[current_module modules] (case state
- {#info info #source source #current_module current_module #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars}
- [current_module modules])]
- (case (get module modules)
- (#Some =module)
- (let [to_alias (list\map (: (-> [Text Global]
- (List Text))
- (function (_ [name definition])
- (case definition
- (#Left _)
- (list)
-
- (#Right [exported? def_type def_meta def_value])
- (if exported?
- (list name)
- (list)))))
- (let [{#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _} =module]
- definitions))]
- (#Right state (list\join to_alias)))
-
- #None
- (#Left ($_ text\compose
- "Unknown module: " (text\encode module) ..\n
- "Current module: " (case current_module
- (#Some current_module)
- (text\encode current_module)
-
- #None
- "???") ..\n
- "Known modules: " (|> modules
- (list\map (function (_ [name module])
- (text$ name)))
- tuple$
- code\encode))))
- ))
-
-(def: (filter p xs)
- (All [a] (-> (-> a Bit) (List a) (List a)))
- (case xs
- #Nil
- (list)
-
- (#Cons x xs')
- (if (p x)
- (#Cons x (filter p xs'))
- (filter p xs'))))
-
-(def: (is_member? cases name)
- (-> (List Text) Text Bit)
- (let [output (list\fold (function (_ case prev)
- (or prev
- (text\= case name)))
- #0
- cases)]
- output))
-
-(def: (try_both f x1 x2)
- (All [a b]
- (-> (-> a (Maybe b)) a a (Maybe b)))
- (case (f x1)
- #None (f x2)
- (#Some y) (#Some y)))
-
-(def: (find_in_env name state)
- (-> Text Lux (Maybe Type))
- (case state
- {#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars}
- (find (: (-> Scope (Maybe Type))
- (function (_ env)
- (case env
- {#name _
- #inner _
- #locals {#counter _ #mappings locals}
- #captured {#counter _ #mappings closure}}
- (try_both (find (: (-> [Text [Type Any]] (Maybe Type))
- (function (_ [bname [type _]])
- (if (text\= name bname)
- (#Some type)
- #None))))
- (: (List [Text [Type Any]]) locals)
- (: (List [Text [Type Any]]) closure)))))
- scopes)))
-
-(def: (find_def_type name state)
- (-> Name Lux (Maybe Type))
- (let [[v_prefix v_name] name
- {#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars} state]
- (case (get v_prefix modules)
- #None
- #None
-
- (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _})
- (case (get v_name definitions)
- #None
- #None
-
- (#Some definition)
- (case definition
- (#Left de_aliased)
- (find_def_type de_aliased state)
-
- (#Right [exported? def_type def_meta def_value])
- (#Some def_type))))))
-
-(def: (find_def_value name state)
- (-> Name (Meta [Type Any]))
- (let [[v_prefix v_name] name
- {#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars} state]
- (case (get v_prefix modules)
- #None
- (#Left (text\compose "Unknown definition: " (name\encode name)))
-
- (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _})
- (case (get v_name definitions)
- #None
- (#Left (text\compose "Unknown definition: " (name\encode name)))
-
- (#Some definition)
- (case definition
- (#Left de_aliased)
- (find_def_value de_aliased state)
-
- (#Right [exported? def_type def_meta def_value])
- (#Right [state [def_type def_value]]))))))
-
-(def: (find_type_var idx bindings)
- (-> Nat (List [Nat (Maybe Type)]) (Maybe Type))
- (case bindings
- #Nil
- #Nil
-
- (#Cons [var bound] bindings')
- (if ("lux i64 =" idx var)
- bound
- (find_type_var idx bindings'))))
-
-(def: (find_type full_name)
- (-> Name (Meta Type))
- (do meta_monad
- [#let [[module name] full_name]
- current_module current_module_name]
- (function (_ compiler)
- (let [temp (if (text\= "" module)
- (case (find_in_env name compiler)
- (#Some struct_type)
- (#Right [compiler struct_type])
-
- _
- (case (find_def_type [current_module name] compiler)
- (#Some struct_type)
- (#Right [compiler struct_type])
-
- _
- (#Left ($_ text\compose "Unknown var: " (name\encode full_name)))))
- (case (find_def_type full_name compiler)
- (#Some struct_type)
- (#Right [compiler struct_type])
-
- _
- (#Left ($_ text\compose "Unknown var: " (name\encode full_name)))))]
- (case temp
- (#Right [compiler (#Var type_id)])
- (let [{#info _ #source _ #current_module _ #modules _
- #scopes _ #type_context type_context #host _
- #seed _ #expected _ #location _ #extensions extensions
- #scope_type_vars _} compiler
- {#ex_counter _ #var_counter _ #var_bindings var_bindings} type_context]
- (case (find_type_var type_id var_bindings)
- #None
- temp
-
- (#Some actualT)
- (#Right [compiler actualT])))
-
- _
- temp))
- )))
-
-(def: (zip/2 xs ys)
- (All [a b] (-> (List a) (List b) (List [a b])))
- (case xs
- (#Cons x xs')
- (case ys
- (#Cons y ys')
- (list& [x y] (zip/2 xs' ys'))
-
- _
- (list))
-
- _
- (list)))
-
-(def: (type\encode type)
- (-> Type Text)
- (case type
- (#Primitive name params)
- (case params
- #Nil
- name
-
- _
- ($_ text\compose "(" name " " (|> params (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")"))
-
- (#Sum _)
- ($_ text\compose "(| " (|> (flatten_variant type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")")
-
- (#Product _)
- ($_ text\compose "[" (|> (flatten_tuple type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) "]")
-
- (#Function _)
- ($_ text\compose "(-> " (|> (flatten_lambda type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")")
-
- (#Parameter id)
- (nat\encode id)
-
- (#Var id)
- ($_ text\compose "⌈v:" (nat\encode id) "⌋")
-
- (#Ex id)
- ($_ text\compose "⟨e:" (nat\encode id) "⟩")
-
- (#UnivQ env body)
- ($_ text\compose "(All " (type\encode body) ")")
-
- (#ExQ env body)
- ($_ text\compose "(Ex " (type\encode body) ")")
-
- (#Apply _)
- (let [[func args] (flatten_app type)]
- ($_ text\compose
- "(" (type\encode func) " "
- (|> args (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose ""))
- ")"))
-
- (#Named name _)
- (name\encode name)
- ))
-
-(macro: #export (^open tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Same as the 'open' macro, but meant to be used as a pattern-matching macro for generating local bindings." ..\n
- "## Takes an 'alias' text for the generated local bindings." ..\n
- "(def: #export (range (^open ''.'') from to)" ..\n
- " (All [a] (-> (Enum a) a a (List a)))" ..\n
- " (range' <= succ from to))"))}
- (case tokens
- (^ (list& [_ (#Form (list [_ (#Text alias)]))] body branches))
- (do meta_monad
- [g!temp (gensym "temp")]
- (wrap (list& g!temp (` (..^open (~ g!temp) (~ (text$ alias)) (~ body))) branches)))
-
- (^ (list [_ (#Identifier name)] [_ (#Text alias)] body))
- (do meta_monad
- [init_type (find_type name)
- struct_evidence (resolve_type_tags init_type)]
- (case struct_evidence
- #None
- (fail (text\compose "Can only 'open' structs: " (type\encode init_type)))
-
- (#Some tags&members)
- (do meta_monad
- [full_body ((: (-> Name [(List Name) (List Type)] Code (Meta Code))
- (function (recur source [tags members] target)
- (let [locals (list\map (function (_ [t_module t_name])
- ["" (de_alias "" t_name alias)])
- tags)
- pattern (tuple$ (list\map identifier$ locals))]
- (do meta_monad
- [enhanced_target (monad\fold meta_monad
- (function (_ [m_local m_type] enhanced_target)
- (do meta_monad
- [m_implementation (resolve_type_tags m_type)]
- (case m_implementation
- (#Some m_tags&members)
- (recur m_local
- m_tags&members
- enhanced_target)
-
- #None
- (wrap enhanced_target))))
- target
- (zip/2 locals members))]
- (wrap (` ({(~ pattern) (~ enhanced_target)} (~ (identifier$ source)))))))))
- name tags&members body)]
- (wrap (list full_body)))))
-
- _
- (fail "Wrong syntax for ^open")))
-
-(macro: #export (cond tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Branching structures with multiple test conditions." ..\n
- "(cond (even? num) ''even''" ..\n
- " (odd? num) ''odd''"
- __paragraph
- " ## else_branch" ..\n
- " ''???'')"))}
- (if ("lux i64 =" 0 (n/% 2 (list\size tokens)))
- (fail "cond requires an uneven number of arguments.")
- (case (list\reverse tokens)
- (^ (list& else branches'))
- (return (list (list\fold (: (-> [Code Code] Code Code)
- (function (_ branch else)
- (let [[right left] branch]
- (` (if (~ left) (~ right) (~ else))))))
- else
- (as_pairs branches'))))
-
- _
- (fail "Wrong syntax for cond"))))
-
-(def: (enumeration' idx xs)
- (All [a] (-> Nat (List a) (List [Nat a])))
- (case xs
- (#Cons x xs')
- (#Cons [idx x] (enumeration' ("lux i64 +" 1 idx) xs'))
-
- #Nil
- #Nil))
-
-(def: (enumeration xs)
- (All [a] (-> (List a) (List [Nat a])))
- (enumeration' 0 xs))
-
-(macro: #export (get@ tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Accesses the value of a record at a given tag." ..\n
- "(get@ #field my_record)"
- __paragraph
- "## Can also work with multiple levels of nesting:" ..\n
- "(get@ [#foo #bar #baz] my_record)"
- __paragraph
- "## And, if only the slot/path is given, generates an accessor function:" ..\n
- "(let [getter (get@ [#foo #bar #baz])]" ..\n
- " (getter my_record))"))}
- (case tokens
- (^ (list [_ (#Tag slot')] record))
- (do meta_monad
- [slot (normalize slot')
- output (resolve_tag slot)
- #let [[idx tags exported? type] output]
- g!_ (gensym "_")
- g!output (gensym "")]
- (case (resolve_struct_type type)
- (#Some members)
- (let [pattern (record$ (list\map (: (-> [Name [Nat Type]] [Code Code])
- (function (_ [[r_prefix r_name] [r_idx r_type]])
- [(tag$ [r_prefix r_name])
- (if ("lux i64 =" idx r_idx)
- g!output
- g!_)]))
- (zip/2 tags (enumeration members))))]
- (return (list (` ({(~ pattern) (~ g!output)} (~ record))))))
-
- _
- (fail "get@ can only use records.")))
-
- (^ (list [_ (#Tuple slots)] record))
- (return (list (list\fold (: (-> Code Code Code)
- (function (_ slot inner)
- (` (..get@ (~ slot) (~ inner)))))
- record
- slots)))
-
- (^ (list selector))
- (do meta_monad
- [g!_ (gensym "_")
- g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!record)) (..get@ (~ selector) (~ g!record)))))))
-
- _
- (fail "Wrong syntax for get@")))
-
-(def: (open_field alias tags my_tag_index [module short] source type)
- (-> Text (List Name) Nat Name Code Type (Meta (List Code)))
- (do meta_monad
- [output (resolve_type_tags type)
- g!_ (gensym "g!_")
- #let [g!output (local_identifier$ short)
- pattern (|> tags
- enumeration
- (list\map (function (_ [tag_idx tag])
- (if ("lux i64 =" my_tag_index tag_idx)
- g!output
- g!_)))
- tuple$)
- source+ (` ({(~ pattern) (~ g!output)} (~ source)))]]
- (case output
- (#Some [tags' members'])
- (do meta_monad
- [decls' (monad\map meta_monad
- (: (-> [Nat Name Type] (Meta (List Code)))
- (function (_ [sub_tag_index sname stype])
- (open_field alias tags' sub_tag_index sname source+ stype)))
- (enumeration (zip/2 tags' members')))]
- (return (list\join decls')))
-
- _
- (return (list (` ("lux def" (~ (local_identifier$ (de_alias "" short alias)))
- (~ source+)
- [(~ location_code) (#.Record #Nil)]
- #0)))))))
-
-(macro: #export (open: tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Opens a implementation and generates a definition for each of its members (including nested members)."
- __paragraph
- "## For example:" ..\n
- "(open: ''i:.'' number)"
- __paragraph
- "## Will generate:" ..\n
- "(def: i:+ (\ number +))" ..\n
- "(def: i:- (\ number -))" ..\n
- "(def: i:* (\ number *))" ..\n
- "..."))}
- (case tokens
- (^ (list [_ (#Text alias)] struct))
- (case struct
- [_ (#Identifier struct_name)]
- (do meta_monad
- [struct_type (find_type struct_name)
- output (resolve_type_tags struct_type)
- #let [source (identifier$ struct_name)]]
- (case output
- (#Some [tags members])
- (do meta_monad
- [decls' (monad\map meta_monad (: (-> [Nat Name Type] (Meta (List Code)))
- (function (_ [tag_index sname stype])
- (open_field alias tags tag_index sname source stype)))
- (enumeration (zip/2 tags members)))]
- (return (list\join decls')))
-
- _
- (fail (text\compose "Can only 'open:' structs: " (type\encode struct_type)))))
-
- _
- (do meta_monad
- [g!struct (gensym "struct")]
- (return (list (` ("lux def" (~ g!struct) (~ struct)
- [(~ location_code) (#.Record #Nil)]
- #0))
- (` (..open: (~ (text$ alias)) (~ g!struct)))))))
-
- _
- (fail "Wrong syntax for open:")))
-
-(macro: #export (|>> tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..\n
- "(|>> (list\map int\encode) (interpose '' '') (fold text\compose ''''))" ..\n
- "## =>" ..\n
- "(function (_ <arg>) (fold text\compose '''' (interpose '' '' (list\map int\encode <arg>))))"))}
- (do meta_monad
- [g!_ (gensym "_")
- g!arg (gensym "arg")]
- (return (list (` (function ((~ g!_) (~ g!arg)) (|> (~ g!arg) (~+ tokens))))))))
-
-(macro: #export (<<| tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..\n
- "(<<| (fold text\compose '''') (interpose '' '') (list\map int\encode))" ..\n
- "## =>" ..\n
- "(function (_ <arg>) (fold text\compose '''' (interpose '' '' (list\map int\encode <arg>))))"))}
- (do meta_monad
- [g!_ (gensym "_")
- g!arg (gensym "arg")]
- (return (list (` (function ((~ g!_) (~ g!arg)) (<| (~+ tokens) (~ g!arg))))))))
-
-(def: (imported_by? import_name module_name)
- (-> Text Text (Meta Bit))
- (do meta_monad
- [module (find_module module_name)
- #let [{#module_hash _ #module_aliases _ #definitions _ #imports imports #tags _ #types _ #module_annotations _ #module_state _} module]]
- (wrap (is_member? imports import_name))))
-
-(def: (read_refer module_name options)
- (-> Text (List Code) (Meta Refer))
- (do meta_monad
- [referral+options (parse_referrals options)
- #let [[referral options] referral+options]
- openings+options (parse_openings options)
- #let [[openings options] openings+options]
- current_module current_module_name]
- (case options
- #Nil
- (wrap {#refer_defs referral
- #refer_open openings})
-
- _
- (fail ($_ text\compose "Wrong syntax for refer @ " current_module
- ..\n (|> options
- (list\map code\encode)
- (interpose " ")
- (list\fold text\compose "")))))))
-
-(def: (write_refer module_name [r_defs r_opens])
- (-> Text Refer (Meta (List Code)))
- (do meta_monad
- [current_module current_module_name
- #let [test_referrals (: (-> Text (List Text) (List Text) (Meta (List Any)))
- (function (_ module_name all_defs referred_defs)
- (monad\map meta_monad
- (: (-> Text (Meta Any))
- (function (_ _def)
- (if (is_member? all_defs _def)
- (return [])
- (fail ($_ text\compose _def " is not defined in module " module_name " @ " current_module)))))
- referred_defs)))]
- defs' (case r_defs
- #All
- (exported_definitions module_name)
-
- (#Only +defs)
- (do meta_monad
- [*defs (exported_definitions module_name)
- _ (test_referrals module_name *defs +defs)]
- (wrap +defs))
-
- (#Exclude _defs)
- (do meta_monad
- [*defs (exported_definitions module_name)
- _ (test_referrals module_name *defs _defs)]
- (wrap (filter (|>> (is_member? _defs) not) *defs)))
-
- #Ignore
- (wrap (list))
-
- #Nothing
- (wrap (list)))
- #let [defs (list\map (: (-> Text Code)
- (function (_ def)
- (` ("lux def alias" (~ (local_identifier$ def)) (~ (identifier$ [module_name def]))))))
- defs')
- openings (|> r_opens
- (list\map (: (-> Openings (List Code))
- (function (_ [alias structs])
- (list\map (function (_ name)
- (` (open: (~ (text$ alias)) (~ (identifier$ [module_name name])))))
- structs))))
- list\join)]]
- (wrap (list\compose defs openings))
- ))
-
-(macro: #export (refer tokens)
- (case tokens
- (^ (list& [_ (#Text module_name)] options))
- (do meta_monad
- [=refer (read_refer module_name options)]
- (write_refer module_name =refer))
-
- _
- (fail "Wrong syntax for refer")))
-
-(def: (refer_to_code module_name module_alias' [r_defs r_opens])
- (-> Text (Maybe Text) Refer Code)
- (let [module_alias (..default module_name module_alias')
- localizations (: (List Code)
- (case r_defs
- #All
- (list (' #*))
-
- (#Only defs)
- (list (form$ (list& (' #+) (list\map local_identifier$ defs))))
-
- (#Exclude defs)
- (list (form$ (list& (' #-) (list\map local_identifier$ defs))))
-
- #Ignore
- (list)
-
- #Nothing
- (list)))
- openings (list\map (function (_ [alias structs])
- (form$ (list& (text$ (..replace_all ..contextual_reference module_alias alias))
- (list\map local_identifier$ structs))))
- r_opens)]
- (` (..refer (~ (text$ module_name))
- (~+ localizations)
- (~+ openings)))))
-
-(macro: #export (module: tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Module_definition macro."
- __paragraph
- "## Can take optional annotations and allows the specification of modules to import."
- __paragraph
- "## Example" ..\n
- "(.module: {#.doc ''Some documentation...''}" ..\n
- " [lux #*" ..\n
- " [control" ..\n
- " [''M'' monad #*]]" ..\n
- " [data" ..\n
- " maybe" ..\n
- " [''.'' name (''#/.'' codec)]]" ..\n
- " [macro" ..\n
- " code]]" ..\n
- " [//" ..\n
- " [type (''.'' equivalence)]])"))}
- (do meta_monad
- [#let [[_meta _imports] (: [(List [Code Code]) (List Code)]
- (case tokens
- (^ (list& [_ (#Record _meta)] _imports))
- [_meta _imports]
-
- _
- [(list) tokens]))]
- current_module current_module_name
- imports (parse_imports #0 current_module "" _imports)
- #let [=imports (|> imports
- (list\map (: (-> Importation Code)
- (function (_ [m_name m_alias =refer])
- (` [(~ (text$ m_name)) (~ (text$ (default "" m_alias)))]))))
- tuple$)
- =refers (list\map (: (-> Importation Code)
- (function (_ [m_name m_alias =refer])
- (refer_to_code m_name m_alias =refer)))
- imports)
- =module (` ("lux def module" [(~ location_code)
- (#.Record (~ (process_def_meta _meta)))]
- (~ =imports)))]]
- (wrap (#Cons =module =refers))))
-
-(macro: #export (\ tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Allows accessing the value of a implementation's member." ..\n
- "(\ codec encode)"
- __paragraph
- "## Also allows using that value as a function." ..\n
- "(\ codec encode +123)"))}
- (case tokens
- (^ (list struct [_ (#Identifier member)]))
- (return (list (` (let [(^open (~ (text$ ..self_reference))) (~ struct)] (~ (identifier$ member))))))
-
- (^ (list& struct member args))
- (return (list (` ((..\ (~ struct) (~ member)) (~+ args)))))
-
- _
- (fail "Wrong syntax for \")))
-
-(macro: #export (set@ tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Sets the value of a record at a given tag." ..\n
- "(set@ #name ''Lux'' lang)"
- __paragraph
- "## Can also work with multiple levels of nesting:" ..\n
- "(set@ [#foo #bar #baz] value my_record)"
- __paragraph
- "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..\n
- "(let [setter (set@ [#foo #bar #baz] value)] (setter my_record))" ..\n
- "(let [setter (set@ [#foo #bar #baz])] (setter value my_record))"))}
- (case tokens
- (^ (list [_ (#Tag slot')] value record))
- (do meta_monad
- [slot (normalize slot')
- output (resolve_tag slot)
- #let [[idx tags exported? type] output]]
- (case (resolve_struct_type type)
- (#Some members)
- (do meta_monad
- [pattern' (monad\map meta_monad
- (: (-> [Name [Nat Type]] (Meta [Name Nat Code]))
- (function (_ [r_slot_name [r_idx r_type]])
- (do meta_monad
- [g!slot (gensym "")]
- (return [r_slot_name r_idx g!slot]))))
- (zip/2 tags (enumeration members)))]
- (let [pattern (record$ (list\map (: (-> [Name Nat Code] [Code Code])
- (function (_ [r_slot_name r_idx r_var])
- [(tag$ r_slot_name)
- r_var]))
- pattern'))
- output (record$ (list\map (: (-> [Name Nat Code] [Code Code])
- (function (_ [r_slot_name r_idx r_var])
- [(tag$ r_slot_name)
- (if ("lux i64 =" idx r_idx)
- value
- r_var)]))
- pattern'))]
- (return (list (` ({(~ pattern) (~ output)} (~ record)))))))
-
- _
- (fail "set@ can only use records.")))
-
- (^ (list [_ (#Tuple slots)] value record))
- (case slots
- #Nil
- (fail "Wrong syntax for set@")
-
- _
- (do meta_monad
- [bindings (monad\map meta_monad
- (: (-> Code (Meta Code))
- (function (_ _) (gensym "temp")))
- slots)
- #let [pairs (zip/2 slots bindings)
- update_expr (list\fold (: (-> [Code Code] Code Code)
- (function (_ [s b] v)
- (` (..set@ (~ s) (~ v) (~ b)))))
- value
- (list\reverse pairs))
- [_ accesses'] (list\fold (: (-> [Code Code] [Code (List (List Code))] [Code (List (List Code))])
- (function (_ [new_slot new_binding] [old_record accesses'])
- [(` (get@ (~ new_slot) (~ new_binding)))
- (#Cons (list new_binding old_record) accesses')]))
- [record (: (List (List Code)) #Nil)]
- pairs)
- accesses (list\join (list\reverse accesses'))]]
- (wrap (list (` (let [(~+ accesses)]
- (~ update_expr)))))))
-
- (^ (list selector value))
- (do meta_monad
- [g!_ (gensym "_")
- g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!record))
- (..set@ (~ selector) (~ value) (~ g!record)))))))
-
- (^ (list selector))
- (do meta_monad
- [g!_ (gensym "_")
- g!value (gensym "value")
- g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!value) (~ g!record))
- (..set@ (~ selector) (~ g!value) (~ g!record)))))))
-
- _
- (fail "Wrong syntax for set@")))
-
-(macro: #export (update@ tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Modifies the value of a record at a given tag, based on some function." ..\n
- "(update@ #age inc person)"
- __paragraph
- "## Can also work with multiple levels of nesting:" ..\n
- "(update@ [#foo #bar #baz] func my_record)"
- __paragraph
- "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..\n
- "(let [updater (update@ [#foo #bar #baz] func)] (updater my_record))" ..\n
- "(let [updater (update@ [#foo #bar #baz])] (updater func my_record))"))}
- (case tokens
- (^ (list [_ (#Tag slot')] fun record))
- (do meta_monad
- [slot (normalize slot')
- output (resolve_tag slot)
- #let [[idx tags exported? type] output]]
- (case (resolve_struct_type type)
- (#Some members)
- (do meta_monad
- [pattern' (monad\map meta_monad
- (: (-> [Name [Nat Type]] (Meta [Name Nat Code]))
- (function (_ [r_slot_name [r_idx r_type]])
- (do meta_monad
- [g!slot (gensym "")]
- (return [r_slot_name r_idx g!slot]))))
- (zip/2 tags (enumeration members)))]
- (let [pattern (record$ (list\map (: (-> [Name Nat Code] [Code Code])
- (function (_ [r_slot_name r_idx r_var])
- [(tag$ r_slot_name)
- r_var]))
- pattern'))
- output (record$ (list\map (: (-> [Name Nat Code] [Code Code])
- (function (_ [r_slot_name r_idx r_var])
- [(tag$ r_slot_name)
- (if ("lux i64 =" idx r_idx)
- (` ((~ fun) (~ r_var)))
- r_var)]))
- pattern'))]
- (return (list (` ({(~ pattern) (~ output)} (~ record)))))))
-
- _
- (fail "update@ can only use records.")))
-
- (^ (list [_ (#Tuple slots)] fun record))
- (case slots
- #Nil
- (fail "Wrong syntax for update@")
-
- _
- (do meta_monad
- [g!record (gensym "record")
- g!temp (gensym "temp")]
- (wrap (list (` (let [(~ g!record) (~ record)
- (~ g!temp) (get@ [(~+ slots)] (~ g!record))]
- (set@ [(~+ slots)] ((~ fun) (~ g!temp)) (~ g!record))))))))
-
- (^ (list selector fun))
- (do meta_monad
- [g!_ (gensym "_")
- g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!record))
- (..update@ (~ selector) (~ fun) (~ g!record)))))))
-
- (^ (list selector))
- (do meta_monad
- [g!_ (gensym "_")
- g!fun (gensym "fun")
- g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!fun) (~ g!record))
- (..update@ (~ selector) (~ g!fun) (~ g!record)))))))
-
- _
- (fail "Wrong syntax for update@")))
-
-(macro: #export (^template tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## It's similar to template, but meant to be used during pattern-matching." ..\n
- "(def: (beta_reduce env type)" ..\n
- " (-> (List Type) Type Type)" ..\n
- " (case type" ..\n
- " (#.Primitive name params)" ..\n
- " (#.Primitive name (list\map (beta_reduce env) params))"
- __paragraph
- " (^template [<tag>]" ..\n
- " [(<tag> left right)" ..\n
- " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..\n
- " ([#.Sum] [#.Product])"
- __paragraph
- " (^template [<tag>]" ..\n
- " [(<tag> left right)" ..\n
- " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..\n
- " ([#.Function] [#.Apply])"
- __paragraph
- " (^template [<tag>]" ..\n
- " [(<tag> old_env def)" ..\n
- " (case old_env" ..\n
- " #.Nil" ..\n
- " (<tag> env def)"
- __paragraph
- " _" ..\n
- " type)])" ..\n
- " ([#.UnivQ] [#.ExQ])"
- __paragraph
- " (#.Parameter idx)" ..\n
- " (default type (list.nth idx env))"
- __paragraph
- " _" ..\n
- " type" ..\n
- " ))"))}
- (case tokens
- (^ (list& [_ (#Form (list [_ (#Tuple bindings)]
- [_ (#Tuple templates)]))]
- [_ (#Form data)]
- branches))
- (case (: (Maybe (List Code))
- (do maybe_monad
- [bindings' (monad\map maybe_monad get_short bindings)
- data' (monad\map maybe_monad tuple->list data)]
- (let [num_bindings (list\size bindings')]
- (if (every? (|>> ("lux i64 =" num_bindings))
- (list\map list\size data'))
- (let [apply (: (-> RepEnv (List Code))
- (function (_ env) (list\map (apply_template env) templates)))]
- (|> data'
- (list\map (compose apply (make_env bindings')))
- list\join
- wrap))
- #None))))
- (#Some output)
- (return (list\compose output branches))
-
- #None
- (fail "Wrong syntax for ^template"))
-
- _
- (fail "Wrong syntax for ^template")))
-
-(def: (find_baseline_column code)
- (-> Code Nat)
- (case code
- (^template [<tag>]
- [[[_ _ column] (<tag> _)]
- column])
- ([#Bit]
- [#Nat]
- [#Int]
- [#Rev]
- [#Frac]
- [#Text]
- [#Identifier]
- [#Tag])
-
- (^template [<tag>]
- [[[_ _ column] (<tag> parts)]
- (list\fold n/min column (list\map find_baseline_column parts))])
- ([#Form]
- [#Tuple])
-
- [[_ _ column] (#Record pairs)]
- (list\fold n/min column
- (list\compose (list\map (|>> first find_baseline_column) pairs)
- (list\map (|>> second find_baseline_column) pairs)))
- ))
-
-(type: Doc_Fragment
- (#Doc_Comment Text)
- (#Doc_Example Code))
-
-(def: (identify_doc_fragment code)
- (-> Code Doc_Fragment)
- (case code
- [_ (#Text comment)]
- (#Doc_Comment comment)
-
- _
- (#Doc_Example code)))
-
-(template [<name> <extension> <doc>]
- [(def: #export <name>
- {#.doc <doc>}
- (All [s] (-> (I64 s) (I64 s)))
- (|>> (<extension> 1)))]
-
- [inc "lux i64 +" "Increment function."]
- [dec "lux i64 -" "Decrement function."]
- )
-
-(def: tag\encode
- (-> Name Text)
- (|>> name\encode (text\compose "#")))
-
-(def: (repeat n x)
- (All [a] (-> Int a (List a)))
- (if ("lux i64 <" n +0)
- (#Cons x (repeat ("lux i64 +" -1 n) x))
- #Nil))
-
-(def: (location_padding baseline [_ old_line old_column] [_ new_line new_column])
- (-> Nat Location Location Text)
- (if ("lux i64 =" old_line new_line)
- (text\join_with "" (repeat (.int ("lux i64 -" old_column new_column)) " "))
- (let [extra_lines (text\join_with "" (repeat (.int ("lux i64 -" old_line new_line)) ..\n))
- space_padding (text\join_with "" (repeat (.int ("lux i64 -" baseline new_column)) " "))]
- (text\compose extra_lines space_padding))))
-
-(def: (text\size x)
- (-> Text Nat)
- ("lux text size" x))
-
-(def: (update_location [file line column] code_text)
- (-> Location Text Location)
- [file line ("lux i64 +" column (text\size code_text))])
-
-(def: (delim_update_location [file line column])
- (-> Location Location)
- [file line (inc column)])
-
-(def: rejoin_all_pairs
- (-> (List [Code Code]) (List Code))
- (|>> (list\map rejoin_pair) list\join))
-
-(def: (doc_example->Text prev_location baseline example)
- (-> Location Nat Code [Location Text])
- (case example
- (^template [<tag> <encode>]
- [[new_location (<tag> value)]
- (let [as_text (<encode> value)]
- [(update_location new_location as_text)
- (text\compose (location_padding baseline prev_location new_location)
- as_text)])])
- ([#Bit bit\encode]
- [#Nat nat\encode]
- [#Int int\encode]
- [#Frac frac\encode]
- [#Text text\encode]
- [#Identifier name\encode]
- [#Tag tag\encode])
-
- (^template [<tag> <open> <close> <prep>]
- [[group_location (<tag> parts)]
- (let [[group_location' parts_text] (list\fold (function (_ part [last_location text_accum])
- (let [[part_location part_text] (doc_example->Text last_location baseline part)]
- [part_location (text\compose text_accum part_text)]))
- [(delim_update_location group_location) ""]
- (<prep> parts))]
- [(delim_update_location group_location')
- ($_ text\compose (location_padding baseline prev_location group_location)
- <open>
- parts_text
- <close>)])])
- ([#Form "(" ")" ..function\identity]
- [#Tuple "[" "]" ..function\identity]
- [#Record "{" "}" rejoin_all_pairs])
-
- [new_location (#Rev value)]
- ("lux io error" "@doc_example->Text Undefined behavior.")
- ))
-
-(def: (with_baseline baseline [file line column])
- (-> Nat Location Location)
- [file line baseline])
-
-(def: (doc_fragment->Text fragment)
- (-> Doc_Fragment Text)
- (case fragment
- (#Doc_Comment comment)
- (|> comment
- (text\split_all_with ..\n)
- (list\map (function (_ line) ($_ text\compose "## " line ..\n)))
- (text\join_with ""))
-
- (#Doc_Example example)
- (let [baseline (find_baseline_column example)
- [location _] example
- [_ text] (doc_example->Text (with_baseline baseline location) baseline example)]
- (text\compose text __paragraph))))
-
-(macro: #export (doc tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Creates code documentation, embedding text as comments and properly formatting the forms it's being given."
- __paragraph
- "## For Example:" ..\n
- "(doc ''Allows arbitrary looping, using the 'recur' form to re-start the loop.''" ..\n
- " ''Can be used in monadic code to create monadic loops.''" ..\n
- " (loop [count +0" ..\n
- " x init]" ..\n
- " (if (< +10 count)" ..\n
- " (recur (inc count) (f x))" ..\n
- " x)))"))}
- (return (list (` [(~ location_code)
- (#.Text (~ (|> tokens
- (list\map (|>> identify_doc_fragment doc_fragment->Text))
- (text\join_with "")
- text$)))]))))
-
-(def: (interleave xs ys)
- (All [a] (-> (List a) (List a) (List a)))
- (case xs
- #Nil
- #Nil
-
- (#Cons x xs')
- (case ys
- #Nil
- #Nil
-
- (#Cons y ys')
- (list& x y (interleave xs' ys')))))
-
-(def: (type_to_code type)
- (-> Type Code)
- (case type
- (#Primitive name params)
- (` (#.Primitive (~ (text$ name)) (~ (untemplate_list (list\map type_to_code params)))))
-
- (^template [<tag>]
- [(<tag> left right)
- (` (<tag> (~ (type_to_code left)) (~ (type_to_code right))))])
- ([#.Sum] [#.Product]
- [#.Function]
- [#.Apply])
-
- (^template [<tag>]
- [(<tag> id)
- (` (<tag> (~ (nat$ id))))])
- ([#.Parameter] [#.Var] [#.Ex])
-
- (^template [<tag>]
- [(<tag> env type)
- (let [env' (untemplate_list (list\map type_to_code env))]
- (` (<tag> (~ env') (~ (type_to_code type)))))])
- ([#.UnivQ] [#.ExQ])
-
- (#Named [module name] anonymous)
- ## TODO: Generate the explicit type definition instead of using
- ## the "identifier$" shortcut below.
- ## (` (#.Named [(~ (text$ module)) (~ (text$ name))]
- ## (~ (type_to_code anonymous))))
- (identifier$ [module name])))
-
-(macro: #export (loop tokens)
- {#.doc (doc "Allows arbitrary looping, using the 'recur' form to re-start the loop."
- "Can be used in monadic code to create monadic loops."
- (loop [count +0
- x init]
- (if (< +10 count)
- (recur (inc count) (f x))
- x))
-
- "Loops can also be given custom names."
- (loop my_loop
- [count +0
- x init]
- (if (< +10 count)
- (my_loop (inc count) (f x))
- x)))}
- (let [?params (case tokens
- (^ (list name [_ (#Tuple bindings)] body))
- (#.Some [name bindings body])
-
- (^ (list [_ (#Tuple bindings)] body))
- (#.Some [(local_identifier$ "recur") bindings body])
-
- _
- #.None)]
- (case ?params
- (#.Some [name bindings body])
- (let [pairs (as_pairs bindings)
- vars (list\map first pairs)
- inits (list\map second pairs)]
- (if (every? identifier? inits)
- (do meta_monad
- [inits' (: (Meta (List Name))
- (case (monad\map maybe_monad get_name inits)
- (#Some inits') (return inits')
- #None (fail "Wrong syntax for loop")))
- init_types (monad\map meta_monad find_type inits')
- expected get_expected_type]
- (return (list (` (("lux type check"
- (-> (~+ (list\map type_to_code init_types))
- (~ (type_to_code expected)))
- (function ((~ name) (~+ vars))
- (~ body)))
- (~+ inits))))))
- (do meta_monad
- [aliases (monad\map meta_monad
- (: (-> Code (Meta Code))
- (function (_ _) (gensym "")))
- inits)]
- (return (list (` (let [(~+ (interleave aliases inits))]
- (.loop (~ name)
- [(~+ (interleave vars aliases))]
- (~ body)))))))))
-
- #.None
- (fail "Wrong syntax for loop"))))
-
-(macro: #export (^slots tokens)
- {#.doc (doc "Allows you to extract record members as local variables with the same names."
- "For example:"
- (let [(^slots [#foo #bar #baz]) quux]
- (f foo bar baz)))}
- (case tokens
- (^ (list& [_ (#Form (list [_ (#Tuple (list& hslot' tslots'))]))] body branches))
- (do meta_monad
- [slots (: (Meta [Name (List Name)])
- (case (: (Maybe [Name (List Name)])
- (do maybe_monad
- [hslot (get_tag hslot')
- tslots (monad\map maybe_monad get_tag tslots')]
- (wrap [hslot tslots])))
- (#Some slots)
- (return slots)
-
- #None
- (fail "Wrong syntax for ^slots")))
- #let [[hslot tslots] slots]
- hslot (normalize hslot)
- tslots (monad\map meta_monad normalize tslots)
- output (resolve_tag hslot)
- g!_ (gensym "_")
- #let [[idx tags exported? type] output
- slot_pairings (list\map (: (-> Name [Text Code])
- (function (_ [module name])
- [name (local_identifier$ name)]))
- (list& hslot tslots))
- pattern (record$ (list\map (: (-> Name [Code Code])
- (function (_ [module name])
- (let [tag (tag$ [module name])]
- (case (get name slot_pairings)
- (#Some binding) [tag binding]
- #None [tag g!_]))))
- tags))]]
- (return (list& pattern body branches)))
-
- _
- (fail "Wrong syntax for ^slots")))
-
-(def: (place_tokens label tokens target)
- (-> Text (List Code) Code (Maybe (List Code)))
- (case target
- (^or [_ (#Bit _)] [_ (#Nat _)] [_ (#Int _)] [_ (#Rev _)] [_ (#Frac _)] [_ (#Text _)] [_ (#Tag _)])
- (#Some (list target))
-
- [_ (#Identifier [prefix name])]
- (if (and (text\= "" prefix)
- (text\= label name))
- (#Some tokens)
- (#Some (list target)))
-
- (^template [<tag>]
- [[location (<tag> elems)]
- (do maybe_monad
- [placements (monad\map maybe_monad (place_tokens label tokens) elems)]
- (wrap (list [location (<tag> (list\join placements))])))])
- ([#Tuple]
- [#Form])
-
- [location (#Record pairs)]
- (do maybe_monad
- [=pairs (monad\map maybe_monad
- (: (-> [Code Code] (Maybe [Code Code]))
- (function (_ [slot value])
- (do maybe_monad
- [slot' (place_tokens label tokens slot)
- value' (place_tokens label tokens value)]
- (case [slot' value']
- (^ [(list =slot) (list =value)])
- (wrap [=slot =value])
-
- _
- #None))))
- pairs)]
- (wrap (list [location (#Record =pairs)])))
- ))
-
-(macro: #export (with_expansions tokens)
- {#.doc (doc "Controlled macro-expansion."
- "Bind an arbitraty number of Code nodes resulting from macro-expansion to local bindings."
- "Wherever a binding appears, the bound Code nodes will be spliced in there."
- (test: "Code operations & implementations"
- (with_expansions
- [<tests> (template [<expr> <text>]
- [(compare <text> (\ Code/encode encode <expr>))]
-
- [(bit #1) "#1"]
- [(int +123) "+123"]
- [(frac +123.0) "+123.0"]
- [(text "123") "'123'"]
- [(tag ["yolo" "lol"]) "#yolo.lol"]
- [(identifier ["yolo" "lol"]) "yolo.lol"]
- [(form (list (bit #1))) "(#1)"]
- [(tuple (list (bit #1))) "[#1]"]
- [(record (list [(bit #1) (int +123)])) "{#1 +123}"]
- )]
- (test_all <tests>))))}
- (case tokens
- (^ (list& [_ (#Tuple bindings)] bodies))
- (case bindings
- (^ (list& [_ (#Identifier ["" var_name])] macro_expr bindings'))
- (do meta_monad
- [expansion (macro_expand_once macro_expr)]
- (case (place_tokens var_name expansion (` (.with_expansions
- [(~+ bindings')]
- (~+ bodies))))
- (#Some output)
- (wrap output)
-
- _
- (fail "[with_expansions] Improper macro expansion.")))
-
- #Nil
- (return bodies)
-
- _
- (fail "Wrong syntax for with_expansions"))
-
- _
- (fail "Wrong syntax for with_expansions")))
-
-(def: (flatten_alias type)
- (-> Type Type)
- (case type
- (^template [<name>]
- [(#Named ["lux" <name>] _)
- type])
- (["Bit"]
- ["Nat"]
- ["Int"]
- ["Rev"]
- ["Frac"]
- ["Text"])
-
- (#Named _ type')
- (flatten_alias type')
-
- _
- type))
-
-(def: (anti_quote_def name)
- (-> Name (Meta Code))
- (do meta_monad
- [type+value (find_def_value name)
- #let [[type value] type+value]]
- (case (flatten_alias type)
- (^template [<name> <type> <wrapper>]
- [(#Named ["lux" <name>] _)
- (wrap (<wrapper> (:as <type> value)))])
- (["Bit" Bit bit$]
- ["Nat" Nat nat$]
- ["Int" Int int$]
- ["Rev" Rev rev$]
- ["Frac" Frac frac$]
- ["Text" Text text$])
-
- _
- (fail (text\compose "Cannot anti-quote type: " (name\encode name))))))
-
-(def: (anti_quote token)
- (-> Code (Meta Code))
- (case token
- [_ (#Identifier [def_prefix def_name])]
- (if (text\= "" def_prefix)
- (do meta_monad
- [current_module current_module_name]
- (anti_quote_def [current_module def_name]))
- (anti_quote_def [def_prefix def_name]))
-
- (^template [<tag>]
- [[meta (<tag> parts)]
- (do meta_monad
- [=parts (monad\map meta_monad anti_quote parts)]
- (wrap [meta (<tag> =parts)]))])
- ([#Form]
- [#Tuple])
-
- [meta (#Record pairs)]
- (do meta_monad
- [=pairs (monad\map meta_monad
- (: (-> [Code Code] (Meta [Code Code]))
- (function (_ [slot value])
- (do meta_monad
- [=value (anti_quote value)]
- (wrap [slot =value]))))
- pairs)]
- (wrap [meta (#Record =pairs)]))
-
- _
- (\ meta_monad return token)
- ## TODO: Figure out why this doesn't work:
- ## (\ meta_monad wrap token)
- ))
-
-(macro: #export (static tokens)
- (case tokens
- (^ (list pattern))
- (do meta_monad
- [pattern' (anti_quote pattern)]
- (wrap (list pattern')))
-
- _
- (fail "Wrong syntax for 'static'.")))
-
-(type: Multi_Level_Case
- [Code (List [Code Code])])
-
-(def: (case_level^ level)
- (-> Code (Meta [Code Code]))
- (case level
- (^ [_ (#Tuple (list expr binding))])
- (return [expr binding])
-
- _
- (return [level (` #1)])
- ))
-
-(def: (multi_level_case^ levels)
- (-> (List Code) (Meta Multi_Level_Case))
- (case levels
- #Nil
- (fail "Multi-level patterns cannot be empty.")
-
- (#Cons init extras)
- (do meta_monad
- [extras' (monad\map meta_monad case_level^ extras)]
- (wrap [init extras']))))
-
-(def: (multi_level_case$ g!_ [[init_pattern levels] body])
- (-> Code [Multi_Level_Case Code] (List Code))
- (let [inner_pattern_body (list\fold (function (_ [calculation pattern] success)
- (let [bind? (case pattern
- [_ (#.Identifier _)]
- #1
-
- _
- #0)]
- (` (case (~ calculation)
- (~ pattern)
- (~ success)
-
- (~+ (if bind?
- (list)
- (list g!_ (` #.None))))))))
- (` (#.Some (~ body)))
- (: (List [Code Code]) (list\reverse levels)))]
- (list init_pattern inner_pattern_body)))
-
-(macro: #export (^multi tokens)
- {#.doc (doc "Multi-level pattern matching."
- "Useful in situations where the result of a branch depends on further refinements on the values being matched."
- "For example:"
- (case (split (size static) uri)
- (^multi (#.Some [chunk uri']) [(text\= static chunk) #1])
- (match_uri endpoint? parts' uri')
-
- _
- (#.Left (format "Static part " (%t static) " does not match URI: " uri)))
-
- "Short-cuts can be taken when using bit tests."
- "The example above can be rewritten as..."
- (case (split (size static) uri)
- (^multi (#.Some [chunk uri']) (text\= static chunk))
- (match_uri endpoint? parts' uri')
-
- _
- (#.Left (format "Static part " (%t static) " does not match URI: " uri))))}
- (case tokens
- (^ (list& [_meta (#Form levels)] body next_branches))
- (do meta_monad
- [mlc (multi_level_case^ levels)
- #let [initial_bind? (case mlc
- [[_ (#.Identifier _)] _]
- #1
-
- _
- #0)]
- expected get_expected_type
- g!temp (gensym "temp")]
- (let [output (list g!temp
- (` ({(#Some (~ g!temp))
- (~ g!temp)
-
- #None
- (case (~ g!temp)
- (~+ next_branches))}
- ("lux type check" (#.Apply (~ (type_to_code expected)) Maybe)
- (case (~ g!temp)
- (~+ (multi_level_case$ g!temp [mlc body]))
-
- (~+ (if initial_bind?
- (list)
- (list g!temp (` #.None)))))))))]
- (wrap output)))
-
- _
- (fail "Wrong syntax for ^multi")))
-
-## TODO: Allow asking the compiler for the name of the definition
-## currently being defined. That name can then be fed into
-## 'wrong_syntax_error' for easier maintenance of the error_messages.
-(def: wrong_syntax_error
- (-> Name Text)
- (|>> name\encode
- (text\compose "Wrong syntax for ")))
-
-(macro: #export (name_of tokens)
- {#.doc (doc "Given an identifier or a tag, gives back a 2 tuple with the prefix and name parts, both as Text."
- (name_of #.doc)
- "=>"
- ["lux" "doc"])}
- (case tokens
- (^template [<tag>]
- [(^ (list [_ (<tag> [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<a> _]))
- (list\fold (function (_ elem acc) (+ (\ Hash<a> hash elem) acc))
- 0
- (to_list set))))}
- (case tokens
- (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] pattern))] body branches))
- (let [g!whole (local_identifier$ name)]
- (return (list& g!whole
- (` (case (~ g!whole) (~ pattern) (~ body)))
- branches)))
-
- _
- (fail (..wrong_syntax_error (name_of ..^@)))))
-
-(macro: #export (^|> tokens)
- {#.doc (doc "Pipes the value being pattern-matched against prior to binding it to a variable."
- (case input
- (^|> value [inc (% 10) (max 1)])
- (foo value)))}
- (case tokens
- (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] [_ (#Tuple steps)]))] body branches))
- (let [g!name (local_identifier$ name)]
- (return (list& g!name
- (` (let [(~ g!name) (|> (~ g!name) (~+ steps))]
- (~ body)))
- branches)))
-
- _
- (fail (..wrong_syntax_error (name_of ..^|>)))))
-
-(macro: #export (:assume tokens)
- {#.doc (doc "Coerces the given expression to the type of whatever is expected."
- (: Dinosaur (:assume (list +1 +2 +3))))}
- (case tokens
- (^ (list expr))
- (do meta_monad
- [type get_expected_type]
- (wrap (list (` ("lux type as" (~ (type_to_code type)) (~ expr))))))
-
- _
- (fail (..wrong_syntax_error (name_of ..:assume)))))
-
-(def: location
- {#.doc "The location of the current expression being analyzed."}
- (Meta Location)
- (function (_ compiler)
- (#Right [compiler (get@ #location compiler)])))
-
-(macro: #export (undefined tokens)
- {#.doc (doc "Meant to be used as a stand-in for functions with undefined implementations."
- "Undefined expressions will type-check against everything, so they make good dummy implementations."
- "However, if an undefined expression is ever evaluated, it will raise a runtime error."
- (def: (square x)
- (-> Int Int)
- (undefined)))}
- (case tokens
- #Nil
- (do meta_monad
- [location ..location
- #let [[module line column] location
- location ($_ "lux text concat" (text\encode module) "," (nat\encode line) "," (nat\encode column))
- message ($_ "lux text concat" "Undefined behavior @ " location)]]
- (wrap (list (` (..error! (~ (text$ message)))))))
-
- _
- (fail (..wrong_syntax_error (name_of ..undefined)))))
-
-(macro: #export (:of tokens)
- {#.doc (doc "Generates the type corresponding to a given expression."
- "Example #1:"
- (let [my_num +123]
- (:of my_num))
- "=="
- Int
- "-------------------"
- "Example #2:"
- (:of +123)
- "=="
- Int)}
- (case tokens
- (^ (list [_ (#Identifier var_name)]))
- (do meta_monad
- [var_type (find_type var_name)]
- (wrap (list (type_to_code var_type))))
-
- (^ (list expression))
- (do meta_monad
- [g!temp (gensym "g!temp")]
- (wrap (list (` (let [(~ g!temp) (~ expression)]
- (..:of (~ g!temp)))))))
-
- _
- (fail (..wrong_syntax_error (name_of ..:of)))))
-
-(def: (parse_complex_declaration tokens)
- (-> (List Code) (Meta [[Text (List Text)] (List Code)]))
- (case tokens
- (^ (list& [_ (#Form (list& [_ (#Identifier ["" name])] args'))] tokens'))
- (do meta_monad
- [args (monad\map meta_monad
- (function (_ arg')
- (case arg'
- [_ (#Identifier ["" arg_name])]
- (wrap arg_name)
-
- _
- (fail "Could not parse an argument.")))
- args')]
- (wrap [[name args] tokens']))
-
- _
- (fail "Could not parse a complex declaration.")
- ))
-
-(def: (parse_any tokens)
- (-> (List Code) (Meta [Code (List Code)]))
- (case tokens
- (^ (list& token tokens'))
- (return [token tokens'])
-
- _
- (fail "Could not parse anything.")
- ))
-
-(def: (parse_many tokens)
- (-> (List Code) (Meta [(List Code) (List Code)]))
- (case tokens
- (^ (list& head tail))
- (return [tokens (list)])
-
- _
- (fail "Could not parse anything.")
- ))
-
-(def: (parse_end tokens)
- (-> (List Code) (Meta Any))
- (case tokens
- (^ (list))
- (return [])
-
- _
- (fail "Expected input Codes to be empty.")
- ))
-
-(def: (parse_anns tokens)
- (-> (List Code) (Meta [Code (List Code)]))
- (case tokens
- (^ (list& [_ (#Record _anns)] tokens'))
- (return [(record$ _anns) tokens'])
-
- _
- (return [(' {}) tokens])
- ))
-
-(macro: #export (template: tokens)
- {#.doc (doc "Define macros in the style of template and ^template."
- "For simple macros that do not need any fancy features."
- (template: (square x)
- (* x x)))}
- (do meta_monad
- [#let [[export? tokens] (export^ tokens)]
- name+args|tokens (parse_complex_declaration tokens)
- #let [[[name args] tokens] name+args|tokens]
- anns|tokens (parse_anns tokens)
- #let [[anns tokens] anns|tokens]
- input_templates|tokens (parse_many tokens)
- #let [[input_templates tokens] input_templates|tokens]
- _ (parse_end tokens)
- g!tokens (gensym "tokens")
- g!compiler (gensym "compiler")
- g!_ (gensym "_")
- #let [rep_env (list\map (function (_ arg)
- [arg (` ((~' ~) (~ (local_identifier$ arg))))])
- args)]
- this_module current_module_name]
- (wrap (list (` (macro: (~+ (export export?))
- ((~ (local_identifier$ name)) (~ g!tokens) (~ g!compiler))
- (~ anns)
- (case (~ g!tokens)
- (^ (list (~+ (list\map local_identifier$ args))))
- (#.Right [(~ g!compiler)
- (list (~+ (list\map (function (_ template)
- (` (`' (~ (replace_syntax rep_env template)))))
- input_templates)))])
-
- (~ g!_)
- (#.Left (~ (text$ (..wrong_syntax_error [this_module name]))))
- )))))
- ))
-
-(macro: #export (as_is tokens compiler)
- (#Right [compiler tokens]))
-
-(macro: #export (char tokens compiler)
- (case tokens
- (^multi (^ (list [_ (#Text input)]))
- (|> input "lux text size" ("lux i64 =" 1)))
- (|> input ("lux text char" 0)
- nat$ list
- [compiler] #Right)
-
- _
- (#Left (..wrong_syntax_error (name_of ..char)))))
-
-(def: target
- (Meta Text)
- (function (_ compiler)
- (#Right [compiler (get@ [#info #target] compiler)])))
-
-(def: (resolve_target choice)
- (-> Code (Meta Text))
- (case choice
- [_ (#Text platform)]
- (..return platform)
-
- [_ (#Identifier identifier)]
- (do meta_monad
- [identifier (..resolve_global_identifier identifier)
- type+value (..find_def_value identifier)
- #let [[type value] type+value]]
- (case (..flatten_alias type)
- (^or (#Primitive "#Text" #Nil)
- (#Named ["lux" "Text"] (#Primitive "#Text" #Nil)))
- (wrap (:as ..Text value))
-
- _
- (fail ($_ text\compose
- "Invalid target platform (must be a value of type Text): " (name\encode identifier)
- " : " (..code\encode (..type_to_code type))))))
-
- _
- (fail ($_ text\compose
- "Invalid target platform syntax: " (..code\encode choice)
- ..\n "Must be either a text literal or an identifier."))))
-
-(def: (target_pick target options default)
- (-> Text (List [Code Code]) (Maybe Code) (Meta (List Code)))
- (case options
- #Nil
- (case default
- #.None
- (fail ($_ text\compose "No code for target platform: " target))
-
- (#.Some default)
- (return (list default)))
-
- (#Cons [key pick] options')
- (do meta_monad
- [platform (..resolve_target key)]
- (if (text\= target platform)
- (return (list pick))
- (target_pick target options' default)))))
-
-(macro: #export (for tokens)
- (do meta_monad
- [target ..target]
- (case tokens
- (^ (list [_ (#Record options)]))
- (target_pick target options #.None)
-
- (^ (list [_ (#Record options)] default))
- (target_pick target options (#.Some default))
-
- _
- (fail (..wrong_syntax_error (name_of ..for))))))
-
-(template [<name> <type> <output>]
- [(def: (<name> xy)
- (All [a b] (-> [a b] <type>))
- (let [[x y] xy]
- <output>))]
-
- [left a x]
- [right b y])
-
-(def: (label_code code)
- (-> Code (Meta [(List [Code Code]) Code]))
- (case code
- (^ [ann (#Form (list [_ (#Identifier ["" "~~"])] expansion))])
- (do meta_monad
- [g!expansion (gensym "g!expansion")]
- (wrap [(list [g!expansion expansion]) g!expansion]))
-
- (^template [<tag>]
- [[ann (<tag> parts)]
- (do meta_monad
- [=parts (monad\map meta_monad label_code parts)]
- (wrap [(list\fold list\compose (list) (list\map left =parts))
- [ann (<tag> (list\map right =parts))]]))])
- ([#Form] [#Tuple])
-
- [ann (#Record kvs)]
- (do meta_monad
- [=kvs (monad\map meta_monad
- (function (_ [key val])
- (do meta_monad
- [=key (label_code key)
- =val (label_code val)
- #let [[key_labels key_labelled] =key
- [val_labels val_labelled] =val]]
- (wrap [(list\compose key_labels val_labels) [key_labelled val_labelled]])))
- kvs)]
- (wrap [(list\fold list\compose (list) (list\map left =kvs))
- [ann (#Record (list\map right =kvs))]]))
-
- _
- (return [(list) code])))
-
-(macro: #export (`` tokens)
- (case tokens
- (^ (list raw))
- (do meta_monad
- [=raw (label_code raw)
- #let [[labels labelled] =raw]]
- (wrap (list (` (with_expansions [(~+ (|> labels
- (list\map (function (_ [label expansion]) (list label expansion)))
- list\join))]
- (~ labelled))))))
-
- _
- (fail (..wrong_syntax_error (name_of ..``)))
- ))
-
-(def: (name$ [module name])
- (-> Name Code)
- (` [(~ (text$ module)) (~ (text$ name))]))
-
-(def: (untemplate_list& last inits)
- (-> Code (List Code) Code)
- (case inits
- #Nil
- last
-
- (#Cons [init inits'])
- (` (#.Cons (~ init) (~ (untemplate_list& last inits'))))))
-
-(def: (untemplate_record g!meta untemplate_pattern fields)
- (-> Code (-> Code (Meta Code))
- (-> (List [Code Code]) (Meta Code)))
- (do meta_monad
- [=fields (monad\map meta_monad
- (function (_ [key value])
- (do meta_monad
- [=key (untemplate_pattern key)
- =value (untemplate_pattern value)]
- (wrap (` [(~ =key) (~ =value)]))))
- fields)]
- (wrap (` [(~ g!meta) (#.Record (~ (untemplate_list =fields)))]))))
-
-(template [<tag> <name>]
- [(def: (<name> g!meta untemplate_pattern elems)
- (-> Code (-> Code (Meta Code))
- (-> (List Code) (Meta Code)))
- (case (list\reverse elems)
- (#Cons [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
- inits)
- (do meta_monad
- [=inits (monad\map meta_monad untemplate_pattern (list\reverse inits))]
- (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list& spliced =inits)))])))
-
- _
- (do meta_monad
- [=elems (monad\map meta_monad untemplate_pattern elems)]
- (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list =elems)))])))))]
-
- [#.Tuple untemplate_tuple]
- [#.Form untemplate_form]
- )
-
-(def: (untemplate_pattern pattern)
- (-> Code (Meta Code))
- (do meta_monad
- [g!meta (gensym "g!meta")]
- (case pattern
- (^template [<tag> <gen>]
- [[_ (<tag> value)]
- (wrap (` [(~ g!meta) (<tag> (~ (<gen> value)))]))])
- ([#.Bit bit$]
- [#.Nat nat$]
- [#.Int int$]
- [#.Rev rev$]
- [#.Frac frac$]
- [#.Text text$]
- [#.Tag name$]
- [#.Identifier name$])
-
- [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))]
- (return unquoted)
-
- [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
- (fail "Cannot use (~+) inside of ^code unless it is the last element in a form or a tuple.")
-
- (^template [<tag> <untemplate>]
- [[_ (<tag> elems)]
- (<untemplate> g!meta untemplate_pattern elems)])
- ([#.Tuple ..untemplate_tuple]
- [#.Form ..untemplate_form])
-
- [_ (#Record fields)]
- (..untemplate_record g!meta untemplate_pattern fields)
- )))
-
-(macro: #export (^code tokens)
- (case tokens
- (^ (list& [_meta (#Form (list template))] body branches))
- (do meta_monad
- [pattern (untemplate_pattern template)]
- (wrap (list& pattern body branches)))
-
- (^ (list template))
- (do meta_monad
- [pattern (untemplate_pattern template)]
- (wrap (list pattern)))
-
- _
- (fail (..wrong_syntax_error (name_of ..^code)))))
-
-(template [<zero> <one>]
- [(def: #export <zero> #0)
- (def: #export <one> #1)]
-
- [false true]
- [no yes]
- [off on]
- )
-
-(macro: #export (:let tokens)
- (case tokens
- (^ (list [_ (#Tuple bindings)] bodyT))
- (if (multiple? 2 (list\size bindings))
- (return (list (` (..with_expansions [(~+ (|> bindings
- ..as_pairs
- (list\map (function (_ [localT valueT])
- (list localT (` (..as_is (~ valueT))))))
- (list\fold list\compose (list))))]
- (~ bodyT)))))
- (..fail ":let requires an even number of parts"))
-
- _
- (..fail (..wrong_syntax_error (name_of ..:let)))))
-
-(macro: #export (try tokens)
- {#.doc (doc (case (try (risky_computation input))
- (#.Right success)
- (do_something success)
-
- (#.Left error)
- (recover_from_failure error)))}
- (case tokens
- (^ (list expression))
- (do meta_monad
- [g!_ (gensym "g!_")]
- (wrap (list (` ("lux try"
- (.function ((~ g!_) (~ g!_))
- (~ expression)))))))
-
- _
- (..fail (..wrong_syntax_error (name_of ..try)))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 12:17:13 +0000