diff options
Diffstat (limited to 'stdlib/source/library')
445 files changed, 89763 insertions, 0 deletions
diff --git a/stdlib/source/library/lux.lux b/stdlib/source/library/lux.lux new file mode 100644 index 000000000..9b01303ea --- /dev/null +++ b/stdlib/source/library/lux.lux @@ -0,0 +1,5958 @@ +("lux def" dummy_location + ["" 0 0] + [["" 0 0] (9 #1 (0 #0))] + #0) + +("lux def" double_quote + ("lux i64 char" +34) + [dummy_location (9 #1 (0 #0))] + #0) + +("lux def" \n + ("lux i64 char" +10) + [dummy_location (9 #1 (0 #0))] + #0) + +("lux def" __paragraph + ("lux text concat" \n \n) + [dummy_location (9 #1 (0 #0))] + #0) + +("lux def" prelude_module + "library/lux" + [dummy_location (9 #1 (0 #0))] + #1) + +## (type: Any +## (Ex [a] a)) +("lux def" Any + ("lux type check type" + (9 #1 ["library/lux" "Any"] + (8 #0 (0 #0) (4 #0 1)))) + [dummy_location + (9 #1 (0 #1 [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 ("lux text concat" + ("lux text concat" "The type of things whose type is irrelevant." __paragraph) + "It can be used to write functions or data-structures that can take, or return, anything."))]] + (0 #0)))] + #1) + +## (type: Nothing +## (All [a] a)) +("lux def" Nothing + ("lux type check type" + (9 #1 ["library/lux" "Nothing"] + (7 #0 (0 #0) (4 #0 1)))) + [dummy_location + (9 #1 (0 #1 [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 ("lux text concat" + ("lux text concat" "The type of things whose type is undefined." __paragraph) + "Useful for expressions that cause errors or other 'extraordinary' conditions."))]] + (0 #0)))] + #1) + +## (type: (List a) +## #Nil +## (#Cons a (List a))) +("lux def type tagged" List + (9 #1 ["library/lux" "List"] + (7 #0 (0 #0) + (1 #0 ## "lux.Nil" + Any + ## "lux.Cons" + (2 #0 (4 #0 1) + (9 #0 (4 #0 1) (4 #0 0)))))) + [dummy_location + (9 #1 (0 #1 [[dummy_location (7 #0 ["library/lux" "type-args"])] + [dummy_location (9 #0 (0 #1 [dummy_location (5 #0 "a")] (0 #0)))]] + (0 #1 [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "A potentially empty list of values.")]] + (0 #0))))] + ["Nil" "Cons"] + #1) + +("lux def" Bit + ("lux type check type" + (9 #1 ["library/lux" "Bit"] + (0 #0 "#Bit" #Nil))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "Your standard, run-of-the-mill boolean values (as bits).")]] + #Nil))] + #1) + +("lux def" I64 + ("lux type check type" + (9 #1 ["library/lux" "I64"] + (7 #0 (0 #0) + (0 #0 "#I64" (#Cons (4 #0 1) #Nil))))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "64-bit integers without any semantics.")]] + #Nil))] + #1) + +("lux def" Nat + ("lux type check type" + (9 #1 ["library/lux" "Nat"] + (0 #0 "#I64" (#Cons (0 #0 "#Nat" #Nil) #Nil)))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 ("lux text concat" + ("lux text concat" "Natural numbers (unsigned integers)." __paragraph) + "They start at zero (0) and extend in the positive direction."))]] + #Nil))] + #1) + +("lux def" Int + ("lux type check type" + (9 #1 ["library/lux" "Int"] + (0 #0 "#I64" (#Cons (0 #0 "#Int" #Nil) #Nil)))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "Your standard, run-of-the-mill integer numbers.")]] + #Nil))] + #1) + +("lux def" Rev + ("lux type check type" + (9 #1 ["library/lux" "Rev"] + (0 #0 "#I64" (#Cons (0 #0 "#Rev" #Nil) #Nil)))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 ("lux text concat" + ("lux text concat" "Fractional numbers that live in the interval [0,1)." __paragraph) + "Useful for probability, and other domains that work within that interval."))]] + #Nil))] + #1) + +("lux def" Frac + ("lux type check type" + (9 #1 ["library/lux" "Frac"] + (0 #0 "#Frac" #Nil))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "Your standard, run-of-the-mill floating-point (fractional) numbers.")]] + #Nil))] + #1) + +("lux def" Text + ("lux type check type" + (9 #1 ["library/lux" "Text"] + (0 #0 "#Text" #Nil))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "Your standard, run-of-the-mill string values.")]] + #Nil))] + #1) + +("lux def" Name + ("lux type check type" + (9 #1 ["library/lux" "Name"] + (2 #0 Text Text))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "A name. It is used as part of Lux syntax to represent identifiers and tags.")]] + #Nil))] + #1) + +## (type: (Maybe a) +## #None +## (#Some a)) +("lux def type tagged" Maybe + (9 #1 ["library/lux" "Maybe"] + (7 #0 #Nil + (1 #0 ## "lux.None" + Any + ## "lux.Some" + (4 #0 1)))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "type-args"])] + [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "a")] #Nil))]] + (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "A potentially missing value.")]] + #Nil)))] + ["None" "Some"] + #1) + +## (type: #rec Type +## (#Primitive Text (List Type)) +## (#Sum Type Type) +## (#Product Type Type) +## (#Function Type Type) +## (#Parameter Nat) +## (#Var Nat) +## (#Ex Nat) +## (#UnivQ (List Type) Type) +## (#ExQ (List Type) Type) +## (#Apply Type Type) +## (#Named Name Type) +## ) +("lux def type tagged" Type + (9 #1 ["library/lux" "Type"] + ({Type + ({Type_List + ({Type_Pair + (9 #0 Nothing + (7 #0 #Nil + (1 #0 ## "lux.Primitive" + (2 #0 Text Type_List) + (1 #0 ## "lux.Sum" + Type_Pair + (1 #0 ## "lux.Product" + Type_Pair + (1 #0 ## "lux.Function" + Type_Pair + (1 #0 ## "lux.Parameter" + Nat + (1 #0 ## "lux.Var" + Nat + (1 #0 ## "lux.Ex" + Nat + (1 #0 ## "lux.UnivQ" + (2 #0 Type_List Type) + (1 #0 ## "lux.ExQ" + (2 #0 Type_List Type) + (1 #0 ## "lux.Apply" + Type_Pair + ## "lux.Named" + (2 #0 Name Type)))))))))))))} + ("lux type check type" (2 #0 Type Type)))} + ("lux type check type" (9 #0 Type List)))} + ("lux type check type" (9 #0 (4 #0 1) (4 #0 0))))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "This type represents the data-structures that are used to specify types themselves.")]] + (#Cons [[dummy_location (7 #0 ["library/lux" "type-rec?"])] + [dummy_location (0 #0 #1)]] + #Nil)))] + ["Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named"] + #1) + +## (type: Location +## {#module Text +## #line Nat +## #column Nat}) +("lux def type tagged" Location + (#Named ["library/lux" "Location"] + (#Product Text (#Product Nat Nat))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "Locations are for specifying the location of Code nodes in Lux files during compilation.")]] + #Nil))] + ["module" "line" "column"] + #1) + +## (type: (Ann m v) +## {#meta m +## #datum v}) +("lux def type tagged" Ann + (#Named ["library/lux" "Ann"] + (#UnivQ #Nil + (#UnivQ #Nil + (#Product (#Parameter 3) + (#Parameter 1))))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "doc"])] + [dummy_location (5 #0 "The type of things that can be annotated with meta-data of arbitrary types.")]] + (#Cons [[dummy_location (7 #0 ["library/lux" "type-args"])] + [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "m")] (#Cons [dummy_location (5 #0 "v")] #Nil)))]] + #Nil)))] + ["meta" "datum"] + #1) + +## (type: (Code' w) +## (#Bit Bit) +## (#Nat Nat) +## (#Int Int) +## (#Rev Rev) +## (#Frac Frac) +## (#Text Text) +## (#Identifier Name) +## (#Tag Name) +## (#Form (List (w (Code' w)))) +## (#Tuple (List (w (Code' w)))) +## (#Record (List [(w (Code' w)) (w (Code' w))]))) +("lux def type tagged" Code' + (#Named ["library/lux" "Code'"] + ({Code + ({Code_List + (#UnivQ #Nil + (#Sum ## "lux.Bit" + Bit + (#Sum ## "lux.Nat" + Nat + (#Sum ## "lux.Int" + Int + (#Sum ## "lux.Rev" + Rev + (#Sum ## "lux.Frac" + Frac + (#Sum ## "lux.Text" + Text + (#Sum ## "lux.Identifier" + Name + (#Sum ## "lux.Tag" + Name + (#Sum ## "lux.Form" + Code_List + (#Sum ## "lux.Tuple" + Code_List + ## "lux.Record" + (#Apply (#Product Code Code) List) + )))))))))) + )} + ("lux type check type" (#Apply Code List)))} + ("lux type check type" (#Apply (#Apply (#Parameter 1) + (#Parameter 0)) + (#Parameter 1))))) + [dummy_location + (9 #1 (#Cons [[dummy_location (7 #0 ["library/lux" "type-args"])] + [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "w")] #Nil))]] + #Nil))] + ["Bit" "Nat" "Int" "Rev" "Frac" "Text" "Identifier" "Tag" "Form" "Tuple" "Record"] + #1) + +## (type: Code +## (Ann Location (Code' (Ann Location)))) +("lux def" Code + (#Named ["library/lux" "Code"] + ({w + (#Apply (#Apply w Code') w)} + ("lux type check type" (#Apply Location Ann)))) + [dummy_location + (#Record (#Cons [[dummy_location (#Tag ["library/lux" "doc"])] + [dummy_location (#Text "The type of Code nodes for Lux syntax.")]] + #Nil))] + #1) + +("lux def" _ann + ("lux type check" + (#Function (#Apply (#Apply Location Ann) + Code') + Code) + ([_ data] + [dummy_location data])) + [dummy_location (#Record #Nil)] + #0) + +("lux def" bit$ + ("lux type check" (#Function Bit Code) + ([_ value] (_ann (#Bit value)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" nat$ + ("lux type check" (#Function Nat Code) + ([_ value] (_ann (#Nat value)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" int$ + ("lux type check" (#Function Int Code) + ([_ value] (_ann (#Int value)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" rev$ + ("lux type check" (#Function Rev Code) + ([_ value] (_ann (#Rev value)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" frac$ + ("lux type check" (#Function Frac Code) + ([_ value] (_ann (#Frac value)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" text$ + ("lux type check" (#Function Text Code) + ([_ text] (_ann (#Text text)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" identifier$ + ("lux type check" (#Function Name Code) + ([_ name] (_ann (#Identifier name)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" local_identifier$ + ("lux type check" (#Function Text Code) + ([_ name] (_ann (#Identifier ["" name])))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" tag$ + ("lux type check" (#Function Name Code) + ([_ name] (_ann (#Tag name)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" local_tag$ + ("lux type check" (#Function Text Code) + ([_ name] (_ann (#Tag ["" name])))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" form$ + ("lux type check" (#Function (#Apply Code List) Code) + ([_ tokens] (_ann (#Form tokens)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" tuple$ + ("lux type check" (#Function (#Apply Code List) Code) + ([_ tokens] (_ann (#Tuple tokens)))) + [dummy_location (#Record #Nil)] + #0) + +("lux def" record$ + ("lux type check" (#Function (#Apply (#Product Code Code) List) Code) + ([_ tokens] (_ann (#Record tokens)))) + [dummy_location (#Record #Nil)] + #0) + +## (type: Definition +## [Bit Type Code Any]) +("lux def" Definition + ("lux type check type" + (#Named ["library/lux" "Definition"] + (#Product Bit (#Product Type (#Product Code Any))))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "Represents all the data associated with a definition: its type, its annotations, and its value.")] + #Nil)) + #1) + +## (type: Alias +## Name) +("lux def" Alias + ("lux type check type" + (#Named ["library/lux" "Alias"] + Name)) + (record$ #Nil) + #1) + +## (type: Global +## (#Alias Alias) +## (#Definition Definition)) +("lux def type tagged" Global + (#Named ["library/lux" "Global"] + (#Sum Alias + Definition)) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "Represents all the data associated with a global constant.")] + #Nil)) + ["Alias" "Definition"] + #1) + +## (type: (Bindings k v) +## {#counter Nat +## #mappings (List [k v])}) +("lux def type tagged" Bindings + (#Named ["library/lux" "Bindings"] + (#UnivQ #Nil + (#UnivQ #Nil + (#Product ## "lux.counter" + Nat + ## "lux.mappings" + (#Apply (#Product (#Parameter 3) + (#Parameter 1)) + List))))) + (record$ (#Cons [(tag$ ["library/lux" "type-args"]) + (tuple$ (#Cons (text$ "k") (#Cons (text$ "v") #Nil)))] + #Nil)) + ["counter" "mappings"] + #1) + +## (type: #export Ref +## (#Local Nat) +## (#Captured Nat)) +("lux def type tagged" Ref + (#Named ["library/lux" "Ref"] + (#Sum ## Local + Nat + ## Captured + Nat)) + (record$ #Nil) + ["Local" "Captured"] + #1) + +## (type: Scope +## {#name (List Text) +## #inner Nat +## #locals (Bindings Text [Type Nat]) +## #captured (Bindings Text [Type Ref])}) +("lux def type tagged" Scope + (#Named ["library/lux" "Scope"] + (#Product ## name + (#Apply Text List) + (#Product ## inner + Nat + (#Product ## locals + (#Apply (#Product Type Nat) (#Apply Text Bindings)) + ## captured + (#Apply (#Product Type Ref) (#Apply Text Bindings)))))) + (record$ #Nil) + ["name" "inner" "locals" "captured"] + #1) + +("lux def" Code_List + ("lux type check type" + (#Apply Code List)) + (record$ #Nil) + #0) + +## (type: (Either l r) +## (#Left l) +## (#Right r)) +("lux def type tagged" Either + (#Named ["library/lux" "Either"] + (#UnivQ #Nil + (#UnivQ #Nil + (#Sum ## "lux.Left" + (#Parameter 3) + ## "lux.Right" + (#Parameter 1))))) + (record$ (#Cons [(tag$ ["library/lux" "type-args"]) + (tuple$ (#Cons (text$ "l") (#Cons (text$ "r") #Nil)))] + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "A choice between two values of different types.")] + #Nil))) + ["Left" "Right"] + #1) + +## (type: Source +## [Location Nat Text]) +("lux def" Source + ("lux type check type" + (#Named ["library/lux" "Source"] + (#Product Location (#Product Nat Text)))) + (record$ #Nil) + #1) + +## (type: Module_State +## #Active +## #Compiled +## #Cached) +("lux def type tagged" Module_State + (#Named ["library/lux" "Module_State"] + (#Sum + ## #Active + Any + (#Sum + ## #Compiled + Any + ## #Cached + Any))) + (record$ #Nil) + ["Active" "Compiled" "Cached"] + #1) + +## (type: Module +## {#module_hash Nat +## #module_aliases (List [Text Text]) +## #definitions (List [Text Global]) +## #imports (List Text) +## #tags (List [Text [Nat (List Name) Bit Type]]) +## #types (List [Text [(List Name) Bit Type]]) +## #module_annotations (Maybe Code) +## #module_state Module_State}) +("lux def type tagged" Module + (#Named ["library/lux" "Module"] + (#Product ## "lux.module_hash" + Nat + (#Product ## "lux.module_aliases" + (#Apply (#Product Text Text) List) + (#Product ## "lux.definitions" + (#Apply (#Product Text Global) List) + (#Product ## "lux.imports" + (#Apply Text List) + (#Product ## "lux.tags" + (#Apply (#Product Text + (#Product Nat + (#Product (#Apply Name List) + (#Product Bit + Type)))) + List) + (#Product ## "lux.types" + (#Apply (#Product Text + (#Product (#Apply Name List) + (#Product Bit + Type))) + List) + (#Product ## "lux.module_annotations" + (#Apply Code Maybe) + Module_State)) + )))))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "All the information contained within a Lux module.")] + #Nil)) + ["module_hash" "module_aliases" "definitions" "imports" "tags" "types" "module_annotations" "module_state"] + #1) + +## (type: Type_Context +## {#ex_counter Nat +## #var_counter Nat +## #var_bindings (List [Nat (Maybe Type)])}) +("lux def type tagged" Type_Context + (#Named ["library/lux" "Type_Context"] + (#Product ## ex_counter + Nat + (#Product ## var_counter + Nat + ## var_bindings + (#Apply (#Product Nat (#Apply Type Maybe)) + List)))) + (record$ #Nil) + ["ex_counter" "var_counter" "var_bindings"] + #1) + +## (type: Mode +## #Build +## #Eval +## #Interpreter) +("lux def type tagged" Mode + (#Named ["library/lux" "Mode"] + (#Sum ## Build + Any + (#Sum ## Eval + Any + ## Interpreter + Any))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "A sign that shows the conditions under which the compiler is running.")] + #Nil)) + ["Build" "Eval" "Interpreter"] + #1) + +## (type: Info +## {#target Text +## #version Text +## #mode Mode}) +("lux def type tagged" Info + (#Named ["library/lux" "Info"] + (#Product + ## target + Text + (#Product + ## version + Text + ## mode + Mode))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "Information about the current version and type of compiler that is running.")] + #Nil)) + ["target" "version" "mode"] + #1) + +## (type: Lux +## {#info Info +## #source Source +## #location Location +## #current_module (Maybe Text) +## #modules (List [Text Module]) +## #scopes (List Scope) +## #type_context Type_Context +## #expected (Maybe Type) +## #seed Nat +## #scope_type_vars (List Nat) +## #extensions Any +## #host Any}) +("lux def type tagged" Lux + (#Named ["library/lux" "Lux"] + (#Product ## "lux.info" + Info + (#Product ## "lux.source" + Source + (#Product ## "lux.location" + Location + (#Product ## "lux.current_module" + (#Apply Text Maybe) + (#Product ## "lux.modules" + (#Apply (#Product Text Module) List) + (#Product ## "lux.scopes" + (#Apply Scope List) + (#Product ## "lux.type_context" + Type_Context + (#Product ## "lux.expected" + (#Apply Type Maybe) + (#Product ## "lux.seed" + Nat + (#Product ## scope_type_vars + (#Apply Nat List) + (#Product ## extensions + Any + ## "lux.host" + Any)))))))))))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "Represents the state of the Lux compiler during a run." __paragraph) + ("lux text concat" + ("lux text concat" "It is provided to macros during their invocation, so they can access compiler data." __paragraph) + "Caveat emptor: Avoid fiddling with it, unless you know what you're doing.")))] + #Nil)) + ["info" "source" "location" "current_module" "modules" "scopes" "type_context" "expected" "seed" "scope_type_vars" "extensions" "host"] + #1) + +## (type: (Meta a) +## (-> Lux (Either Text [Lux a]))) +("lux def" Meta + ("lux type check type" + (#Named ["library/lux" "Meta"] + (#UnivQ #Nil + (#Function Lux + (#Apply (#Product Lux (#Parameter 1)) + (#Apply Text Either)))))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "Computations that can have access to the state of the compiler." __paragraph) + "These computations may fail, or modify the state of the compiler."))] + (#Cons [(tag$ ["library/lux" "type-args"]) + (tuple$ (#Cons (text$ "a") #Nil))] + #Nil))) + #1) + +## (type: Macro' +## (-> (List Code) (Meta (List Code)))) +("lux def" Macro' + ("lux type check type" + (#Named ["library/lux" "Macro'"] + (#Function Code_List (#Apply Code_List Meta)))) + (record$ #Nil) + #1) + +## (type: Macro +## (primitive "#Macro")) +("lux def" Macro + ("lux type check type" + (#Named ["library/lux" "Macro"] + (#Primitive "#Macro" #Nil))) + (record$ (#Cons [(tag$ ["library/lux" "doc"]) + (text$ "Functions that run at compile-time and allow you to transform and extend the language in powerful ways.")] + #Nil)) + #1) + +## Base functions & macros +("lux def" return + ("lux type check" + (#UnivQ #Nil + (#Function (#Parameter 1) + (#Function Lux + (#Apply (#Product Lux + (#Parameter 1)) + (#Apply Text Either))))) + ([_ val] + ([_ state] + (#Right state val)))) + (record$ #Nil) + #0) + +("lux def" fail + ("lux type check" + (#UnivQ #Nil + (#Function Text + (#Function Lux + (#Apply (#Product Lux + (#Parameter 1)) + (#Apply Text Either))))) + ([_ msg] + ([_ state] + (#Left msg)))) + (record$ #Nil) + #0) + +("lux def" let'' + ("lux macro" + ([_ tokens] + ({(#Cons lhs (#Cons rhs (#Cons body #Nil))) + (return (#Cons (form$ (#Cons (record$ (#Cons [lhs body] #Nil)) (#Cons rhs #Nil))) + #Nil)) + + _ + (fail "Wrong syntax for let''")} + tokens))) + (record$ #.Nil) + #0) + +("lux def" function'' + ("lux macro" + ([_ tokens] + ({(#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil)) + (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" ""])) + (#Cons arg #Nil)))) + (#Cons ({#Nil + body + + _ + (_ann (#Form (#Cons (_ann (#Identifier ["library/lux" "function''"])) + (#Cons (_ann (#Tuple args')) + (#Cons body #Nil)))))} + args') + #Nil)))) + #Nil)) + + (#Cons [_ (#Identifier ["" self])] (#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil))) + (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" self])) + (#Cons arg #Nil)))) + (#Cons ({#Nil + body + + _ + (_ann (#Form (#Cons (_ann (#Identifier ["library/lux" "function''"])) + (#Cons (_ann (#Tuple args')) + (#Cons body #Nil)))))} + args') + #Nil)))) + #Nil)) + + _ + (fail "Wrong syntax for function''")} + tokens))) + (record$ #.Nil) + #0) + +("lux def" location_code + ("lux type check" Code + (tuple$ (#Cons (text$ "") (#Cons (nat$ 0) (#Cons (nat$ 0) #Nil))))) + (record$ #Nil) + #0) + +("lux def" meta_code + ("lux type check" (#Function Name (#Function Code Code)) + ([_ tag] + ([_ value] + (tuple$ (#Cons location_code + (#Cons (form$ (#Cons (tag$ tag) (#Cons value #Nil))) + #Nil)))))) + (record$ #Nil) + #0) + +("lux def" flag_meta + ("lux type check" (#Function Text Code) + ([_ tag] + (tuple$ (#Cons [(meta_code ["library/lux" "Tag"] (tuple$ (#Cons (text$ "library/lux") (#Cons (text$ tag) #Nil)))) + (#Cons [(meta_code ["library/lux" "Bit"] (bit$ #1)) + #Nil])])))) + (record$ #Nil) + #0) + +("lux def" doc_meta + ("lux type check" (#Function Text (#Product Code Code)) + (function'' [doc] [(tag$ ["library/lux" "doc"]) (text$ doc)])) + (record$ #Nil) + #0) + +("lux def" as_def + ("lux type check" (#Function Code (#Function Code (#Function Code (#Function Bit Code)))) + (function'' [name value annotations exported?] + (form$ (#Cons (text$ "lux def") (#Cons name (#Cons value (#Cons annotations (#Cons (bit$ exported?) #Nil)))))))) + (record$ #Nil) + #0) + +("lux def" as_checked + ("lux type check" (#Function Code (#Function Code Code)) + (function'' [type value] + (form$ (#Cons (text$ "lux type check") (#Cons type (#Cons value #Nil)))))) + (record$ #Nil) + #0) + +("lux def" as_function + ("lux type check" (#Function Code (#Function (#Apply Code List) (#Function Code Code))) + (function'' [self inputs output] + (form$ (#Cons (identifier$ ["library/lux" "function''"]) + (#Cons self + (#Cons (tuple$ inputs) + (#Cons output #Nil))))))) + (record$ #Nil) + #0) + +("lux def" as_macro + ("lux type check" (#Function Code Code) + (function'' [expression] + (form$ (#Cons (text$ "lux macro") + (#Cons expression + #Nil))))) + (record$ #Nil) + #0) + +("lux def" def:'' + ("lux macro" + (function'' [tokens] + ({(#Cons [[_ (#Tag ["" "export"])] + (#Cons [[_ (#Form (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (#Cons [(as_def name (as_checked type (as_function name args body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + #1) + #Nil])) + + (#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (#Cons [(as_def name (as_checked type body) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + #1) + #Nil])) + + (#Cons [[_ (#Form (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(as_def name (as_checked type (as_function name args body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + #0) + #Nil])) + + (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(as_def name (as_checked type body) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + #0) + #Nil])) + + _ + (fail "Wrong syntax for def''")} + tokens))) + (record$ #.Nil) + #0) + +("lux def" macro:' + ("lux macro" + (function'' [tokens] + ({(#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil)) + (return (#Cons (as_def name (as_macro (as_function name args body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons (tag$ ["library/lux" "Nil"]) + #Nil))) + #0) + #Nil)) + + (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil))) + (return (#Cons (as_def name (as_macro (as_function name args body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons (tag$ ["library/lux" "Nil"]) + #Nil))) + #1) + #Nil)) + + (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons meta_data (#Cons body #Nil)))) + (return (#Cons (as_def name (as_macro (as_function name args body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta_data + #Nil))) + #1) + #Nil)) + + _ + (fail "Wrong syntax for macro:'")} + tokens))) + (record$ #.Nil) + #0) + +(macro:' #export (comment tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Throws away any code given to it." __paragraph) + ("lux text concat" + ("lux text concat" "## Great for commenting-out code, while retaining syntax high-lighting and formatting in your text editor." __paragraph) + "(comment +1 +2 +3 +4)")))] + #Nil) + (return #Nil)) + +(macro:' ($' tokens) + ({(#Cons x #Nil) + (return tokens) + + (#Cons x (#Cons y xs)) + (return (#Cons (form$ (#Cons (identifier$ ["library/lux" "$'"]) + (#Cons (form$ (#Cons (tag$ ["library/lux" "Apply"]) + (#Cons y (#Cons x #Nil)))) + xs))) + #Nil)) + + _ + (fail "Wrong syntax for $'")} + tokens)) + +(def:'' (list\map f xs) + #Nil + (#UnivQ #Nil + (#UnivQ #Nil + (#Function (#Function (#Parameter 3) (#Parameter 1)) + (#Function ($' List (#Parameter 3)) + ($' List (#Parameter 1)))))) + ({#Nil + #Nil + + (#Cons x xs') + (#Cons (f x) (list\map f xs'))} + xs)) + +(def:'' RepEnv + #Nil + Type + ($' List (#Product Text Code))) + +(def:'' (make_env xs ys) + #Nil + (#Function ($' List Text) (#Function ($' List Code) RepEnv)) + ({[(#Cons x xs') (#Cons y ys')] + (#Cons [x y] (make_env xs' ys')) + + _ + #Nil} + [xs ys])) + +(def:'' (text\= reference sample) + #Nil + (#Function Text (#Function Text Bit)) + ("lux text =" reference sample)) + +(def:'' (get_rep key env) + #Nil + (#Function Text (#Function RepEnv ($' Maybe Code))) + ({#Nil + #None + + (#Cons [k v] env') + ({#1 + (#Some v) + + #0 + (get_rep key env')} + (text\= k key))} + env)) + +(def:'' (replace_syntax reps syntax) + #Nil + (#Function RepEnv (#Function Code Code)) + ({[_ (#Identifier "" name)] + ({(#Some replacement) + replacement + + #None + syntax} + (get_rep name reps)) + + [meta (#Form parts)] + [meta (#Form (list\map (replace_syntax reps) parts))] + + [meta (#Tuple members)] + [meta (#Tuple (list\map (replace_syntax reps) members))] + + [meta (#Record slots)] + [meta (#Record (list\map ("lux type check" (#Function (#Product Code Code) (#Product Code Code)) + (function'' [slot] + ({[k v] + [(replace_syntax reps k) (replace_syntax reps v)]} + slot))) + slots))] + + _ + syntax} + syntax)) + +(def:'' (n/* param subject) + (#.Cons (doc_meta "Nat(ural) multiplication.") #.Nil) + (#Function Nat (#Function Nat Nat)) + ("lux type as" Nat + ("lux i64 *" + ("lux type as" Int param) + ("lux type as" Int subject)))) + +(def:'' (update_parameters code) + #Nil + (#Function Code Code) + ({[_ (#Tuple members)] + (tuple$ (list\map update_parameters members)) + + [_ (#Record pairs)] + (record$ (list\map ("lux type check" (#Function (#Product Code Code) (#Product Code Code)) + (function'' [pair] + (let'' [name val] pair + [name (update_parameters val)]))) + pairs)) + + [_ (#Form (#Cons [_ (#Tag "library/lux" "Parameter")] (#Cons [_ (#Nat idx)] #Nil)))] + (form$ (#Cons (tag$ ["library/lux" "Parameter"]) (#Cons (nat$ ("lux i64 +" 2 idx)) #Nil))) + + [_ (#Form members)] + (form$ (list\map update_parameters members)) + + _ + code} + code)) + +(def:'' (parse_quantified_args args next) + #Nil + ## (-> (List Code) (-> (List Text) (Meta (List Code))) (Meta (List Code))) + (#Function ($' List Code) + (#Function (#Function ($' List Text) (#Apply ($' List Code) Meta)) + (#Apply ($' List Code) Meta) + )) + ({#Nil + (next #Nil) + + (#Cons [_ (#Identifier "" arg_name)] args') + (parse_quantified_args args' (function'' [names] (next (#Cons arg_name names)))) + + _ + (fail "Expected identifier.")} + args)) + +(def:'' (make_parameter idx) + #Nil + (#Function Nat Code) + (form$ (#Cons (tag$ ["library/lux" "Parameter"]) (#Cons (nat$ idx) #Nil)))) + +(def:'' (list\fold f init xs) + #Nil + ## (All [a b] (-> (-> b a a) a (List b) a)) + (#UnivQ #Nil (#UnivQ #Nil (#Function (#Function (#Parameter 1) + (#Function (#Parameter 3) + (#Parameter 3))) + (#Function (#Parameter 3) + (#Function ($' List (#Parameter 1)) + (#Parameter 3)))))) + ({#Nil + init + + (#Cons x xs') + (list\fold f (f x init) xs')} + xs)) + +(def:'' (list\size list) + #Nil + (#UnivQ #Nil + (#Function ($' List (#Parameter 1)) Nat)) + (list\fold (function'' [_ acc] ("lux i64 +" 1 acc)) 0 list)) + +(macro:' #export (All tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Universal quantification." __paragraph) + ("lux text concat" + ("lux text concat" "(All [a] (-> a a))" __paragraph) + ("lux text concat" + ("lux text concat" "## A name can be provided, to specify a recursive type." __paragraph) + "(All List [a] (| Any [a (List a)]))"))))] + #Nil) + (let'' [self_name tokens] ({(#Cons [_ (#Identifier "" self_name)] tokens) + [self_name tokens] + + _ + ["" tokens]} + tokens) + ({(#Cons [_ (#Tuple args)] (#Cons body #Nil)) + (parse_quantified_args args + (function'' [names] + (let'' body' (list\fold ("lux type check" (#Function Text (#Function Code Code)) + (function'' [name' body'] + (form$ (#Cons (tag$ ["library/lux" "UnivQ"]) + (#Cons (tag$ ["library/lux" "Nil"]) + (#Cons (replace_syntax (#Cons [name' (make_parameter 1)] #Nil) + (update_parameters body')) #Nil)))))) + body + names) + (return (#Cons ({[#1 _] + body' + + [_ #Nil] + body' + + [#0 _] + (replace_syntax (#Cons [self_name (make_parameter (n/* 2 ("lux i64 -" 1 (list\size names))))] + #Nil) + body')} + [(text\= "" self_name) names]) + #Nil))))) + + _ + (fail "Wrong syntax for All")} + tokens))) + +(macro:' #export (Ex tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Existential quantification." __paragraph) + ("lux text concat" + ("lux text concat" "(Ex [a] [(Codec Text a) a])" __paragraph) + ("lux text concat" + ("lux text concat" "## A name can be provided, to specify a recursive type." __paragraph) + "(Ex Self [a] [(Codec Text a) a (List (Self a))])"))))] + #Nil) + (let'' [self_name tokens] ({(#Cons [_ (#Identifier "" self_name)] tokens) + [self_name tokens] + + _ + ["" tokens]} + tokens) + ({(#Cons [_ (#Tuple args)] (#Cons body #Nil)) + (parse_quantified_args args + (function'' [names] + (let'' body' (list\fold ("lux type check" (#Function Text (#Function Code Code)) + (function'' [name' body'] + (form$ (#Cons (tag$ ["library/lux" "ExQ"]) + (#Cons (tag$ ["library/lux" "Nil"]) + (#Cons (replace_syntax (#Cons [name' (make_parameter 1)] #Nil) + (update_parameters body')) #Nil)))))) + body + names) + (return (#Cons ({[#1 _] + body' + + [_ #Nil] + body' + + [#0 _] + (replace_syntax (#Cons [self_name (make_parameter (n/* 2 ("lux i64 -" 1 (list\size names))))] + #Nil) + body')} + [(text\= "" self_name) names]) + #Nil))))) + + _ + (fail "Wrong syntax for Ex")} + tokens))) + +(def:'' (list\reverse list) + #Nil + (All [a] (#Function ($' List a) ($' List a))) + (list\fold ("lux type check" (All [a] (#Function a (#Function ($' List a) ($' List a)))) + (function'' [head tail] (#Cons head tail))) + #Nil + list)) + +(macro:' #export (-> tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Function types:" __paragraph) + ("lux text concat" + ("lux text concat" "(-> Int Int Int)" __paragraph) + "## This is the type of a function that takes 2 Ints and returns an Int.")))] + #Nil) + ({(#Cons output inputs) + (return (#Cons (list\fold ("lux type check" (#Function Code (#Function Code Code)) + (function'' [i o] (form$ (#Cons (tag$ ["library/lux" "Function"]) (#Cons i (#Cons o #Nil)))))) + output + inputs) + #Nil)) + + _ + (fail "Wrong syntax for ->")} + (list\reverse tokens))) + +(macro:' #export (list xs) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## List-construction macro." __paragraph) + "(list +1 +2 +3)"))] + #Nil) + (return (#Cons (list\fold (function'' [head tail] + (form$ (#Cons (tag$ ["library/lux" "Cons"]) + (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) + #Nil)))) + (tag$ ["library/lux" "Nil"]) + (list\reverse xs)) + #Nil))) + +(macro:' #export (list& xs) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## List-construction macro, with the last element being a tail-list." __paragraph) + ("lux text concat" + ("lux text concat" "## In other words, this macro prepends elements to another list." __paragraph) + "(list& +1 +2 +3 (list +4 +5 +6))")))] + #Nil) + ({(#Cons last init) + (return (list (list\fold (function'' [head tail] + (form$ (list (tag$ ["library/lux" "Cons"]) + (tuple$ (list head tail))))) + last + init))) + + _ + (fail "Wrong syntax for list&")} + (list\reverse xs))) + +(macro:' #export (& tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Tuple types:" __paragraph) + ("lux text concat" + ("lux text concat" "(& Text Int Bit)" __paragraph) + ("lux text concat" + ("lux text concat" "## Any." __paragraph) + "(&)"))))] + #Nil) + ({#Nil + (return (list (identifier$ ["library/lux" "Any"]))) + + (#Cons last prevs) + (return (list (list\fold (function'' [left right] (form$ (list (tag$ ["library/lux" "Product"]) left right))) + last + prevs)))} + (list\reverse tokens))) + +(macro:' #export (| tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Variant types:" __paragraph) + ("lux text concat" + ("lux text concat" "(| Text Int Bit)" __paragraph) + ("lux text concat" + ("lux text concat" "## Nothing." __paragraph) + "(|)"))))] + #Nil) + ({#Nil + (return (list (identifier$ ["library/lux" "Nothing"]))) + + (#Cons last prevs) + (return (list (list\fold (function'' [left right] (form$ (list (tag$ ["library/lux" "Sum"]) left right))) + last + prevs)))} + (list\reverse tokens))) + +(macro:' (function' tokens) + (let'' [name tokens'] ({(#Cons [[_ (#Identifier ["" name])] tokens']) + [name tokens'] + + _ + ["" tokens]} + tokens) + ({(#Cons [[_ (#Tuple args)] (#Cons [body #Nil])]) + ({#Nil + (fail "function' requires a non-empty arguments tuple.") + + (#Cons [harg targs]) + (return (list (form$ (list (tuple$ (list (local_identifier$ name) + harg)) + (list\fold (function'' [arg body'] + (form$ (list (tuple$ (list (local_identifier$ "") + arg)) + body'))) + body + (list\reverse targs))))))} + args) + + _ + (fail "Wrong syntax for function'")} + tokens'))) + +(macro:' (def:''' tokens) + ({(#Cons [[_ (#Tag ["" "export"])] + (#Cons [[_ (#Form (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (list (form$ (list (text$ "lux def") + name + (form$ (list (text$ "lux type check") + type + (form$ (list (identifier$ ["library/lux" "function'"]) + name + (tuple$ args) + body)))) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + (bit$ #1))))) + + (#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (list (form$ (list (text$ "lux def") + name + (form$ (list (text$ "lux type check") + type + body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + (bit$ #1))))) + + (#Cons [[_ (#Form (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (text$ "lux def") + name + (form$ (list (text$ "lux type check") + type + (form$ (list (identifier$ ["library/lux" "function'"]) + name + (tuple$ args) + body)))) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + (bit$ #0))))) + + (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (text$ "lux def") + name + (form$ (list (text$ "lux type check") type body)) + (form$ (#Cons (identifier$ ["library/lux" "record$"]) + (#Cons meta + #Nil))) + (bit$ #0))))) + + _ + (fail "Wrong syntax for def:'''")} + tokens)) + +(def:''' (as_pairs xs) + #Nil + (All [a] (-> ($' List a) ($' List (& a a)))) + ({(#Cons x (#Cons y xs')) + (#Cons [x y] (as_pairs xs')) + + _ + #Nil} + xs)) + +(macro:' (let' tokens) + ({(#Cons [[_ (#Tuple bindings)] (#Cons [body #Nil])]) + (return (list (list\fold ("lux type check" (-> (& Code Code) Code + Code) + (function' [binding body] + ({[label value] + (form$ (list (record$ (list [label body])) value))} + binding))) + body + (list\reverse (as_pairs bindings))))) + + _ + (fail "Wrong syntax for let'")} + tokens)) + +(def:''' (any? p xs) + #Nil + (All [a] + (-> (-> a Bit) ($' List a) Bit)) + ({#Nil + #0 + + (#Cons x xs') + ({#1 #1 + #0 (any? p xs')} + (p x))} + xs)) + +(def:''' (wrap_meta content) + #Nil + (-> Code Code) + (tuple$ (list (tuple$ (list (text$ "") (nat$ 0) (nat$ 0))) + content))) + +(def:''' (untemplate_list tokens) + #Nil + (-> ($' List Code) Code) + ({#Nil + (_ann (#Tag ["library/lux" "Nil"])) + + (#Cons [token tokens']) + (_ann (#Form (list (_ann (#Tag ["library/lux" "Cons"])) token (untemplate_list tokens'))))} + tokens)) + +(def:''' (list\compose xs ys) + #Nil + (All [a] (-> ($' List a) ($' List a) ($' List a))) + ({(#Cons x xs') + (#Cons x (list\compose xs' ys)) + + #Nil + ys} + xs)) + +(def:''' (_$_joiner op a1 a2) + #Nil + (-> Code Code Code Code) + ({[_ (#Form parts)] + (form$ (list\compose parts (list a1 a2))) + + _ + (form$ (list op a1 a2))} + op)) + +(def:''' (function/flip func) + #Nil + (All [a b c] + (-> (-> a b c) (-> b a c))) + (function' [right left] + (func left right))) + +(macro:' #export (_$ tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Left-association for the application of binary functions over variadic arguments." ..\n) + ("lux text concat" + ("lux text concat" "(_$ text\compose ''Hello, '' name ''. How are you?'')" ..\n) + ("lux text concat" + ("lux text concat" "## =>" ..\n) + "(text\compose (text\compose ''Hello, '' name) ''. How are you?'')"))))] + #Nil) + ({(#Cons op tokens') + ({(#Cons first nexts) + (return (list (list\fold (function/flip (_$_joiner op)) first nexts))) + + _ + (fail "Wrong syntax for _$")} + tokens') + + _ + (fail "Wrong syntax for _$")} + tokens)) + +(macro:' #export ($_ tokens) + (#Cons [(tag$ ["library/lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "## Right-association for the application of binary functions over variadic arguments." ..\n) + ("lux text concat" + ("lux text concat" "($_ text\compose ''Hello, '' name ''. How are you?'')" ..\n) + ("lux text concat" + ("lux text concat" "## =>" ..\n) + "(text\compose ''Hello, '' (text\compose name ''. How are you?''))"))))] + #Nil) + ({(#Cons op tokens') + ({(#Cons last prevs) + (return (list (list\fold (_$_joiner op) last prevs))) + + _ + (fail "Wrong syntax for $_")} + (list\reverse tokens')) + + _ + (fail "Wrong syntax for $_")} + tokens)) + +## (interface: (Monad m) +## (: (All [a] (-> a (m a))) +## wrap) +## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) +## bind)) +("lux def type tagged" Monad + (#Named ["library/lux" "Monad"] + (All [m] + (& (All [a] (-> a ($' m a))) + (All [a b] (-> (-> a ($' m b)) + ($' m a) + ($' m b)))))) + (record$ (list)) + ["wrap" "bind"] + #0) + +(def:''' maybe_monad + #Nil + ($' Monad Maybe) + {#wrap + (function' [x] (#Some x)) + + #bind + (function' [f ma] + ({#None #None + (#Some a) (f a)} + ma))}) + +(def:''' meta_monad + #Nil + ($' Monad Meta) + {#wrap + (function' [x] + (function' [state] + (#Right state x))) + + #bind + (function' [f ma] + (function' [state] + ({(#Left msg) + (#Left msg) + + (#Right [state' a]) + (f a state')} + (ma state))))}) + +(macro:' (do tokens) + ({(#Cons monad (#Cons [_ (#Tuple bindings)] (#Cons body #Nil))) + (let' [g!wrap (local_identifier$ "wrap") + g!bind (local_identifier$ " bind ") + body' (list\fold ("lux type check" (-> (& Code Code) Code Code) + (function' [binding body'] + (let' [[var value] binding] + ({[_ (#Tag "" "let")] + (form$ (list (identifier$ ["library/lux" "let'"]) value body')) + + _ + (form$ (list g!bind + (form$ (list (tuple$ (list (local_identifier$ "") var)) body')) + value))} + var)))) + body + (list\reverse (as_pairs bindings)))] + (return (list (form$ (list (record$ (list [(record$ (list [(tag$ ["library/lux" "wrap"]) g!wrap] [(tag$ ["library/lux" "bind"]) g!bind])) + body'])) + monad))))) + + _ + (fail "Wrong syntax for do")} + tokens)) + +(def:''' (monad\map m f xs) + #Nil + ## (All [m a b] + ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) + (All [m a b] + (-> ($' Monad m) + (-> a ($' m b)) + ($' List a) + ($' m ($' List b)))) + (let' [{#wrap wrap #bind _} m] + ({#Nil + (wrap #Nil) + + (#Cons x xs') + (do m + [y (f x) + ys (monad\map m f xs')] + (wrap (#Cons y ys)))} + xs))) + +(def:''' (monad\fold m f y xs) + #Nil + ## (All [m a b] + ## (-> (Monad m) (-> a b (m b)) b (List a) (m b))) + (All [m a b] + (-> ($' Monad m) + (-> a b ($' m b)) + b + ($' List a) + ($' m b))) + (let' [{#wrap wrap #bind _} m] + ({#Nil + (wrap y) + + (#Cons x xs') + (do m + [y' (f x y)] + (monad\fold m f y' xs'))} + xs))) + +(macro:' #export (if tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "Picks which expression to evaluate based on a bit test value." __paragraph + "(if #1 ''Oh, yeah!'' ''Aw hell naw!'')" __paragraph + "=> ''Oh, yeah!''"))]) + ({(#Cons test (#Cons then (#Cons else #Nil))) + (return (list (form$ (list (record$ (list [(bit$ #1) then] + [(bit$ #0) else])) + test)))) + + _ + (fail "Wrong syntax for if")} + tokens)) + +(def:''' (get k plist) + #Nil + (All [a] + (-> Text ($' List (& Text a)) ($' Maybe a))) + ({(#Cons [[k' v] plist']) + (if (text\= k k') + (#Some v) + (get k plist')) + + #Nil + #None} + plist)) + +(def:''' (put k v dict) + #Nil + (All [a] + (-> Text a ($' List (& Text a)) ($' List (& Text a)))) + ({#Nil + (list [k v]) + + (#Cons [[k' v'] dict']) + (if (text\= k k') + (#Cons [[k' v] dict']) + (#Cons [[k' v'] (put k v dict')]))} + dict)) + +(def:''' (text\compose x y) + #Nil + (-> Text Text Text) + ("lux text concat" x y)) + +(def:''' (name\encode full_name) + #Nil + (-> Name Text) + (let' [[module name] full_name] + ({"" name + _ ($_ text\compose module "." name)} + module))) + +(def:''' (get_meta tag def_meta) + #Nil + (-> Name Code ($' Maybe Code)) + (let' [[prefix name] tag] + ({[_ (#Record def_meta)] + ({(#Cons [key value] def_meta') + ({[_ (#Tag [prefix' name'])] + ({[#1 #1] + (#Some value) + + _ + (get_meta tag (record$ def_meta'))} + [(text\= prefix prefix') + (text\= name name')]) + + _ + (get_meta tag (record$ def_meta'))} + key) + + #Nil + #None} + def_meta) + + _ + #None} + def_meta))) + +(def:''' (resolve_global_identifier full_name state) + #Nil + (-> Name ($' Meta Name)) + (let' [[module name] full_name + {#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} state] + ({(#Some {#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _}) + ({(#Some constant) + ({(#Left real_name) + (#Right [state real_name]) + + (#Right [exported? def_type def_meta def_value]) + (#Right [state full_name])} + constant) + + #None + (#Left ($_ text\compose "Unknown definition: " (name\encode full_name)))} + (get name definitions)) + + #None + (#Left ($_ text\compose "Unknown module: " module " @ " (name\encode full_name)))} + (get module modules)))) + +(def:''' (as_code_list expression) + #Nil + (-> Code Code) + (let' [type (form$ (list (tag$ ["library/lux" "Apply"]) + (identifier$ ["library/lux" "Code"]) + (identifier$ ["library/lux" "List"])))] + (form$ (list (text$ "lux type check") type expression)))) + +(def:''' (splice replace? untemplate elems) + #Nil + (-> Bit (-> Code ($' Meta Code)) ($' List Code) ($' Meta Code)) + ({#1 + ({#Nil + (return (tag$ ["library/lux" "Nil"])) + + (#Cons lastI inits) + (do meta_monad + [lastO ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] + (wrap (as_code_list spliced)) + + _ + (do meta_monad + [lastO (untemplate lastI)] + (wrap (as_code_list (form$ (list (tag$ ["library/lux" "Cons"]) + (tuple$ (list lastO (tag$ ["library/lux" "Nil"]))))))))} + lastI)] + (monad\fold meta_monad + (function' [leftI rightO] + ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] + (let' [g!in-module (form$ (list (text$ "lux in-module") + (text$ "library/lux") + (identifier$ ["library/lux" "list\compose"])))] + (wrap (form$ (list g!in-module (as_code_list spliced) rightO)))) + + _ + (do meta_monad + [leftO (untemplate leftI)] + (wrap (form$ (list (tag$ ["library/lux" "Cons"]) (tuple$ (list leftO rightO))))))} + leftI)) + lastO + inits))} + (list\reverse elems)) + #0 + (do meta_monad + [=elems (monad\map meta_monad untemplate elems)] + (wrap (untemplate_list =elems)))} + replace?)) + +(def:''' (untemplate_text value) + #Nil + (-> Text Code) + (wrap_meta (form$ (list (tag$ ["library/lux" "Text"]) (text$ value))))) + +(def:''' (untemplate replace? subst token) + #Nil + (-> Bit Text Code ($' Meta Code)) + ({[_ [_ (#Bit value)]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Bit"]) (bit$ value))))) + + [_ [_ (#Nat value)]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Nat"]) (nat$ value))))) + + [_ [_ (#Int value)]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Int"]) (int$ value))))) + + [_ [_ (#Rev value)]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Rev"]) (rev$ value))))) + + [_ [_ (#Frac value)]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Frac"]) (frac$ value))))) + + [_ [_ (#Text value)]] + (return (untemplate_text value)) + + [#0 [_ (#Tag [module name])]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Tag"]) (tuple$ (list (text$ module) (text$ name))))))) + + [#1 [_ (#Tag [module name])]] + (let' [module' ({"" + subst + + _ + module} + module)] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Tag"]) (tuple$ (list (text$ module') (text$ name)))))))) + + [#1 [_ (#Identifier [module name])]] + (do meta_monad + [real_name ({"" + (if (text\= "" subst) + (wrap [module name]) + (resolve_global_identifier [subst name])) + + _ + (wrap [module name])} + module) + #let [[module name] real_name]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Identifier"]) (tuple$ (list (text$ module) (text$ name)))))))) + + [#0 [_ (#Identifier [module name])]] + (return (wrap_meta (form$ (list (tag$ ["library/lux" "Identifier"]) (tuple$ (list (text$ module) (text$ name))))))) + + [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))]] + (return (form$ (list (text$ "lux type check") + (identifier$ ["library/lux" "Code"]) + unquoted))) + + [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~!"])] (#Cons [dependent #Nil])]))]] + (do meta_monad + [independent (untemplate replace? subst dependent)] + (wrap (wrap_meta (form$ (list (tag$ ["library/lux" "Form"]) + (untemplate_list (list (untemplate_text "lux in-module") + (untemplate_text subst) + independent))))))) + + [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~'"])] (#Cons [keep_quoted #Nil])]))]] + (untemplate #0 subst keep_quoted) + + [_ [meta (#Form elems)]] + (do meta_monad + [output (splice replace? (untemplate replace? subst) elems) + #let [[_ output'] (wrap_meta (form$ (list (tag$ ["library/lux" "Form"]) output)))]] + (wrap [meta output'])) + + [_ [meta (#Tuple elems)]] + (do meta_monad + [output (splice replace? (untemplate replace? subst) elems) + #let [[_ output'] (wrap_meta (form$ (list (tag$ ["library/lux" "Tuple"]) output)))]] + (wrap [meta output'])) + + [_ [_ (#Record fields)]] + (do meta_monad + [=fields (monad\map meta_monad + ("lux type check" (-> (& Code Code) ($' Meta Code)) + (function' [kv] + (let' [[k v] kv] + (do meta_monad + [=k (untemplate replace? subst k) + =v (untemplate replace? subst v)] + (wrap (tuple$ (list =k =v))))))) + fields)] + (wrap (wrap_meta (form$ (list (tag$ ["library/lux" "Record"]) (untemplate_list =fields))))))} + [replace? token])) + +(macro:' #export (primitive tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Macro to treat define new primitive types." __paragraph + "(primitive ''java.lang.Object'')" __paragraph + "(primitive ''java.util.List'' [(primitive ''java.lang.Long'')])"))]) + ({(#Cons [_ (#Text class_name)] #Nil) + (return (list (form$ (list (tag$ ["library/lux" "Primitive"]) (text$ class_name) (tag$ ["library/lux" "Nil"]))))) + + (#Cons [_ (#Text class_name)] (#Cons [_ (#Tuple params)] #Nil)) + (return (list (form$ (list (tag$ ["library/lux" "Primitive"]) (text$ class_name) (untemplate_list params))))) + + _ + (fail "Wrong syntax for primitive")} + tokens)) + +(def:'' (current_module_name state) + #Nil + ($' Meta Text) + ({{#info info #source source #current_module current_module #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} + ({(#Some module_name) + (#Right [state module_name]) + + _ + (#Left "Cannot get the module name without a module!")} + current_module)} + state)) + +(macro:' #export (` tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Hygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph + "## All unprefixed macros will receive their parent module's prefix if imported; otherwise will receive the prefix of the module on which the quasi-quote is being used." __paragraph + "(` (def: (~ name) (function ((~' _) (~+ args)) (~ body))))"))]) + ({(#Cons template #Nil) + (do meta_monad + [current_module current_module_name + =template (untemplate #1 current_module template)] + (wrap (list (form$ (list (text$ "lux type check") + (identifier$ ["library/lux" "Code"]) + =template))))) + + _ + (fail "Wrong syntax for `")} + tokens)) + +(macro:' #export (`' tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph + "(`' (def: (~ name) (function (_ (~+ args)) (~ body))))"))]) + ({(#Cons template #Nil) + (do meta_monad + [=template (untemplate #1 "" template)] + (wrap (list (form$ (list (text$ "lux type check") (identifier$ ["library/lux" "Code"]) =template))))) + + _ + (fail "Wrong syntax for `")} + tokens)) + +(macro:' #export (' tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Quotation as a macro." __paragraph + "(' YOLO)"))]) + ({(#Cons template #Nil) + (do meta_monad + [=template (untemplate #0 "" template)] + (wrap (list (form$ (list (text$ "lux type check") (identifier$ ["library/lux" "Code"]) =template))))) + + _ + (fail "Wrong syntax for '")} + tokens)) + +(macro:' #export (|> tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Piping macro." __paragraph + "(|> elems (list\map int\encode) (interpose '' '') (fold text\compose ''''))" __paragraph + "## =>" __paragraph + "(fold text\compose '''' (interpose '' '' (list\map int\encode elems)))"))]) + ({(#Cons [init apps]) + (return (list (list\fold ("lux type check" (-> Code Code Code) + (function' [app acc] + ({[_ (#Tuple parts)] + (tuple$ (list\compose parts (list acc))) + + [_ (#Form parts)] + (form$ (list\compose parts (list acc))) + + _ + (` ((~ app) (~ acc)))} + app))) + init + apps))) + + _ + (fail "Wrong syntax for |>")} + tokens)) + +(macro:' #export (<| tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Reverse piping macro." __paragraph + "(<| (fold text\compose '''') (interpose '' '') (list\map int\encode) elems)" __paragraph + "## =>" __paragraph + "(fold text\compose '''' (interpose '' '' (list\map int\encode elems)))"))]) + ({(#Cons [init apps]) + (return (list (list\fold ("lux type check" (-> Code Code Code) + (function' [app acc] + ({[_ (#Tuple parts)] + (tuple$ (list\compose parts (list acc))) + + [_ (#Form parts)] + (form$ (list\compose parts (list acc))) + + _ + (` ((~ app) (~ acc)))} + app))) + init + apps))) + + _ + (fail "Wrong syntax for <|")} + (list\reverse tokens))) + +(def:''' (compose f g) + (list [(tag$ ["library/lux" "doc"]) + (text$ "Function composition.")]) + (All [a b c] + (-> (-> b c) (-> a b) (-> a c))) + (function' [x] (f (g x)))) + +(def:''' (get_name x) + #Nil + (-> Code ($' Maybe Name)) + ({[_ (#Identifier sname)] + (#Some sname) + + _ + #None} + x)) + +(def:''' (get_tag x) + #Nil + (-> Code ($' Maybe Name)) + ({[_ (#Tag sname)] + (#Some sname) + + _ + #None} + x)) + +(def:''' (get_short x) + #Nil + (-> Code ($' Maybe Text)) + ({[_ (#Identifier "" sname)] + (#Some sname) + + _ + #None} + x)) + +(def:''' (tuple->list tuple) + #Nil + (-> Code ($' Maybe ($' List Code))) + ({[_ (#Tuple members)] + (#Some members) + + _ + #None} + tuple)) + +(def:''' (apply_template env template) + #Nil + (-> RepEnv Code Code) + ({[_ (#Identifier "" sname)] + ({(#Some subst) + subst + + _ + template} + (get_rep sname env)) + + [meta (#Tuple elems)] + [meta (#Tuple (list\map (apply_template env) elems))] + + [meta (#Form elems)] + [meta (#Form (list\map (apply_template env) elems))] + + [meta (#Record members)] + [meta (#Record (list\map ("lux type check" (-> (& Code Code) (& Code Code)) + (function' [kv] + (let' [[slot value] kv] + [(apply_template env slot) (apply_template env value)]))) + members))] + + _ + template} + template)) + +(def:''' (every? p xs) + #Nil + (All [a] + (-> (-> a Bit) ($' List a) Bit)) + (list\fold (function' [_2 _1] (if _1 (p _2) #0)) #1 xs)) + +(def:''' (high_bits value) + (list) + (-> ($' I64 Any) I64) + ("lux i64 right-shift" 32 value)) + +(def:''' low_mask + (list) + I64 + (|> 1 ("lux i64 left-shift" 32) ("lux i64 -" 1))) + +(def:''' (low_bits value) + (list) + (-> ($' I64 Any) I64) + ("lux i64 and" low_mask value)) + +(def:''' (n/< reference sample) + (list) + (-> Nat Nat Bit) + (let' [referenceH (high_bits reference) + sampleH (high_bits sample)] + (if ("lux i64 <" referenceH sampleH) + #1 + (if ("lux i64 =" referenceH sampleH) + ("lux i64 <" + (low_bits reference) + (low_bits sample)) + #0)))) + +(def:''' (n/<= reference sample) + (list) + (-> Nat Nat Bit) + (if (n/< reference sample) + #1 + ("lux i64 =" reference sample))) + +(def:''' (list\join xs) + #Nil + (All [a] + (-> ($' List ($' List a)) ($' List a))) + (list\fold list\compose #Nil (list\reverse xs))) + +(macro:' #export (template tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary." __paragraph + "(template [<name> <diff>]" ..\n + " " "[(def: #export <name> (-> Int Int) (+ <diff>))]" __paragraph + " " "[inc +1]" ..\n + " " "[dec -1]"))]) + ({(#Cons [[_ (#Tuple bindings)] (#Cons [[_ (#Tuple templates)] data])]) + ({[(#Some bindings') (#Some data')] + (let' [apply ("lux type check" (-> RepEnv ($' List Code)) + (function' [env] (list\map (apply_template env) templates))) + num_bindings (list\size bindings')] + (if (every? (function' [size] ("lux i64 =" num_bindings size)) + (list\map list\size data')) + (|> data' + (list\map (compose apply (make_env bindings'))) + list\join + return) + (fail "Irregular arguments tuples for template."))) + + _ + (fail "Wrong syntax for template")} + [(monad\map maybe_monad get_short bindings) + (monad\map maybe_monad tuple->list data)]) + + _ + (fail "Wrong syntax for template")} + tokens)) + +(def:''' (n// param subject) + (list) + (-> Nat Nat Nat) + (if ("lux i64 <" +0 ("lux type as" Int param)) + (if (n/< param subject) + 0 + 1) + (let' [quotient (|> subject + ("lux i64 right-shift" 1) + ("lux i64 /" ("lux type as" Int param)) + ("lux i64 left-shift" 1)) + flat ("lux i64 *" + ("lux type as" Int param) + ("lux type as" Int quotient)) + remainder ("lux i64 -" flat subject)] + (if (n/< param remainder) + quotient + ("lux i64 +" 1 quotient))))) + +(def:''' (n/% param subject) + (list) + (-> Nat Nat Nat) + (let' [flat ("lux i64 *" + ("lux type as" Int param) + ("lux type as" Int (n// param subject)))] + ("lux i64 -" flat subject))) + +(def:''' (n/min left right) + (list) + (-> Nat Nat Nat) + (if (n/< right left) + left + right)) + +(def:''' (bit\encode x) + #Nil + (-> Bit Text) + (if x "#1" "#0")) + +(def:''' (digit::format digit) + #Nil + (-> Nat Text) + ({0 "0" + 1 "1" 2 "2" 3 "3" + 4 "4" 5 "5" 6 "6" + 7 "7" 8 "8" 9 "9" + _ ("lux io error" "@digit::format Undefined behavior.")} + digit)) + +(def:''' (nat\encode value) + #Nil + (-> Nat Text) + ({0 + "0" + + _ + (let' [loop ("lux type check" (-> Nat Text Text) + (function' recur [input output] + (if ("lux i64 =" 0 input) + output + (recur (n// 10 input) + (text\compose (|> input (n/% 10) digit::format) + output)))))] + (loop value ""))} + value)) + +(def:''' (int\abs value) + #Nil + (-> Int Int) + (if ("lux i64 <" +0 value) + ("lux i64 *" -1 value) + value)) + +(def:''' (int\encode value) + #Nil + (-> Int Text) + (if ("lux i64 =" +0 value) + "+0" + (let' [sign (if ("lux i64 <" value +0) + "+" + "-")] + (("lux type check" (-> Int Text Text) + (function' recur [input output] + (if ("lux i64 =" +0 input) + (text\compose sign output) + (recur ("lux i64 /" +10 input) + (text\compose (|> input ("lux i64 %" +10) ("lux type as" Nat) digit::format) + output))))) + (|> value ("lux i64 /" +10) int\abs) + (|> value ("lux i64 %" +10) int\abs ("lux type as" Nat) digit::format))))) + +(def:''' (frac\encode x) + #Nil + (-> Frac Text) + ("lux f64 encode" x)) + +(def:''' (multiple? div n) + #Nil + (-> Nat Nat Bit) + (|> n (n/% div) ("lux i64 =" 0))) + +(def:''' #export (not x) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Bit negation." __paragraph + "(not #1) => #0" __paragraph + "(not #0) => #1"))]) + (-> Bit Bit) + (if x #0 #1)) + +(def:''' (macro_type? type) + (list) + (-> Type Bit) + ({(#Named ["library/lux" "Macro"] (#Primitive "#Macro" #Nil)) + #1 + + _ + #0} + type)) + +(def:''' (find_macro' modules current_module module name) + #Nil + (-> ($' List (& Text Module)) + Text Text Text + ($' Maybe Macro)) + (do maybe_monad + [$module (get module modules) + gdef (let' [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags #types types #module_annotations _ #module_state _} ("lux type check" Module $module)] + (get name bindings))] + ({(#Left [r_module r_name]) + (find_macro' modules current_module r_module r_name) + + (#Right [exported? def_type def_meta def_value]) + (if (macro_type? def_type) + (if exported? + (#Some ("lux type as" Macro def_value)) + (if (text\= module current_module) + (#Some ("lux type as" Macro def_value)) + #None)) + #None)} + ("lux type check" Global gdef)))) + +(def:''' (normalize name) + #Nil + (-> Name ($' Meta Name)) + ({["" name] + (do meta_monad + [module_name current_module_name] + (wrap [module_name name])) + + _ + (return name)} + name)) + +(def:''' (find_macro full_name) + #Nil + (-> Name ($' Meta ($' Maybe Macro))) + (do meta_monad + [current_module current_module_name] + (let' [[module name] full_name] + (function' [state] + ({{#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected + #location location #extensions extensions + #scope_type_vars scope_type_vars} + (#Right state (find_macro' modules current_module module name))} + state))))) + +(def:''' (macro? name) + #Nil + (-> Name ($' Meta Bit)) + (do meta_monad + [name (normalize name) + output (find_macro name)] + (wrap ({(#Some _) #1 + #None #0} + output)))) + +(def:''' (interpose sep xs) + #Nil + (All [a] + (-> a ($' List a) ($' List a))) + ({#Nil + xs + + (#Cons [x #Nil]) + xs + + (#Cons [x xs']) + (list& x sep (interpose sep xs'))} + xs)) + +(def:''' (macro_expand_once token) + #Nil + (-> Code ($' Meta ($' List Code))) + ({[_ (#Form (#Cons [_ (#Identifier macro_name)] args))] + (do meta_monad + [macro_name' (normalize macro_name) + ?macro (find_macro macro_name')] + ({(#Some macro) + (("lux type as" Macro' macro) args) + + #None + (return (list token))} + ?macro)) + + _ + (return (list token))} + token)) + +(def:''' (macro_expand token) + #Nil + (-> Code ($' Meta ($' List Code))) + ({[_ (#Form (#Cons [_ (#Identifier macro_name)] args))] + (do meta_monad + [macro_name' (normalize macro_name) + ?macro (find_macro macro_name')] + ({(#Some macro) + (do meta_monad + [expansion (("lux type as" Macro' macro) args) + expansion' (monad\map meta_monad macro_expand expansion)] + (wrap (list\join expansion'))) + + #None + (return (list token))} + ?macro)) + + _ + (return (list token))} + token)) + +(def:''' (macro_expand_all syntax) + #Nil + (-> Code ($' Meta ($' List Code))) + ({[_ (#Form (#Cons [_ (#Identifier macro_name)] args))] + (do meta_monad + [macro_name' (normalize macro_name) + ?macro (find_macro macro_name')] + ({(#Some macro) + (do meta_monad + [expansion (("lux type as" Macro' macro) args) + expansion' (monad\map meta_monad macro_expand_all expansion)] + (wrap (list\join expansion'))) + + #None + (do meta_monad + [args' (monad\map meta_monad macro_expand_all args)] + (wrap (list (form$ (#Cons (identifier$ macro_name) (list\join args'))))))} + ?macro)) + + [_ (#Form members)] + (do meta_monad + [members' (monad\map meta_monad macro_expand_all members)] + (wrap (list (form$ (list\join members'))))) + + [_ (#Tuple members)] + (do meta_monad + [members' (monad\map meta_monad macro_expand_all members)] + (wrap (list (tuple$ (list\join members'))))) + + [_ (#Record pairs)] + (do meta_monad + [pairs' (monad\map meta_monad + (function' [kv] + (let' [[key val] kv] + (do meta_monad + [val' (macro_expand_all val)] + ({(#Cons val'' #Nil) + (return [key val'']) + + _ + (fail "The value-part of a KV-pair in a record must macro-expand to a single Code.")} + val')))) + pairs)] + (wrap (list (record$ pairs')))) + + _ + (return (list syntax))} + syntax)) + +(def:''' (walk_type type) + #Nil + (-> Code Code) + ({[_ (#Form (#Cons [_ (#Tag tag)] parts))] + (form$ (#Cons [(tag$ tag) (list\map walk_type parts)])) + + [_ (#Tuple members)] + (` (& (~+ (list\map walk_type members)))) + + [_ (#Form (#Cons [_ (#Text "lux in-module")] + (#Cons [_ (#Text module)] + (#Cons type' + #Nil))))] + (` ("lux in-module" (~ (text$ module)) (~ (walk_type type')))) + + [_ (#Form (#Cons [_ (#Identifier ["" ":~"])] (#Cons expression #Nil)))] + expression + + [_ (#Form (#Cons type_fn args))] + (list\fold ("lux type check" (-> Code Code Code) + (function' [arg type_fn] (` (#.Apply (~ arg) (~ type_fn))))) + (walk_type type_fn) + (list\map walk_type args)) + + _ + type} + type)) + +(macro:' #export (type tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Takes a type expression and returns it's representation as data-structure." __paragraph + "(type (All [a] (Maybe (List a))))"))]) + ({(#Cons type #Nil) + (do meta_monad + [type+ (macro_expand_all type)] + ({(#Cons type' #Nil) + (wrap (list (walk_type type'))) + + _ + (fail "The expansion of the type-syntax had to yield a single element.")} + type+)) + + _ + (fail "Wrong syntax for type")} + tokens)) + +(macro:' #export (: tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## The type-annotation macro." __paragraph + "(: (List Int) (list +1 +2 +3))"))]) + ({(#Cons type (#Cons value #Nil)) + (return (list (` ("lux type check" (type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :")} + tokens)) + +(macro:' #export (:as tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## The type-coercion macro." __paragraph + "(:as Dinosaur (list +1 +2 +3))"))]) + ({(#Cons type (#Cons value #Nil)) + (return (list (` ("lux type as" (type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :as")} + tokens)) + +(def:''' (empty? xs) + #Nil + (All [a] (-> ($' List a) Bit)) + ({#Nil #1 + _ #0} + xs)) + +(template [<name> <type> <value>] + [(def:''' (<name> xy) + #Nil + (All [a b] (-> (& a b) <type>)) + (let' [[x y] xy] <value>))] + + [first a x] + [second b y]) + +(def:''' (unfold_type_def type_codes) + #Nil + (-> ($' List Code) ($' Meta (& Code ($' Maybe ($' List Text))))) + ({(#Cons [_ (#Record pairs)] #Nil) + (do meta_monad + [members (monad\map meta_monad + (: (-> [Code Code] (Meta [Text Code])) + (function' [pair] + ({[[_ (#Tag "" member_name)] member_type] + (return [member_name member_type]) + + _ + (fail "Wrong syntax for variant case.")} + pair))) + pairs)] + (return [(` (& (~+ (list\map second members)))) + (#Some (list\map first members))])) + + (#Cons type #Nil) + ({[_ (#Tag "" member_name)] + (return [(` .Any) (#Some (list member_name))]) + + [_ (#Form (#Cons [_ (#Tag "" member_name)] member_types))] + (return [(` (& (~+ member_types))) (#Some (list member_name))]) + + _ + (return [type #None])} + type) + + (#Cons case cases) + (do meta_monad + [members (monad\map meta_monad + (: (-> Code (Meta [Text Code])) + (function' [case] + ({[_ (#Tag "" member_name)] + (return [member_name (` .Any)]) + + [_ (#Form (#Cons [_ (#Tag "" member_name)] (#Cons member_type #Nil)))] + (return [member_name member_type]) + + [_ (#Form (#Cons [_ (#Tag "" member_name)] member_types))] + (return [member_name (` (& (~+ member_types)))]) + + _ + (fail "Wrong syntax for variant case.")} + case))) + (list& case cases))] + (return [(` (| (~+ (list\map second members)))) + (#Some (list\map first members))])) + + _ + (fail "Improper type-definition syntax")} + type_codes)) + +(def:''' (gensym prefix state) + #Nil + (-> Text ($' Meta Code)) + ({{#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected + #location location #extensions extensions + #scope_type_vars scope_type_vars} + (#Right {#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed ("lux i64 +" 1 seed) #expected expected + #location location #extensions extensions + #scope_type_vars scope_type_vars} + (local_identifier$ ($_ text\compose "__gensym__" prefix (nat\encode seed))))} + state)) + +(macro:' #export (Rec tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Parameter-less recursive types." __paragraph + "## A name has to be given to the whole type, to use it within its body." __paragraph + "(Rec Self [Int (List Self)])"))]) + ({(#Cons [_ (#Identifier "" name)] (#Cons body #Nil)) + (let' [body' (replace_syntax (list [name (` (#.Apply (~ (make_parameter 1)) (~ (make_parameter 0))))]) + (update_parameters body))] + (return (list (` (#.Apply .Nothing (#.UnivQ #.Nil (~ body'))))))) + + _ + (fail "Wrong syntax for Rec")} + tokens)) + +(macro:' #export (exec tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Sequential execution of expressions (great for side-effects)." __paragraph + "(exec" ..\n + " " "(log! ''#1'')" ..\n + " " "(log! ''#2'')" ..\n + " " "(log! ''#3'')" ..\n + "''YOLO'')"))]) + ({(#Cons value actions) + (let' [dummy (local_identifier$ "")] + (return (list (list\fold ("lux type check" (-> Code Code Code) + (function' [pre post] (` ({(~ dummy) (~ post)} + (~ pre))))) + value + actions)))) + + _ + (fail "Wrong syntax for exec")} + (list\reverse tokens))) + +(macro:' (def:' tokens) + (let' [[export? tokens'] ({(#Cons [_ (#Tag ["" "export"])] tokens') + [#1 tokens'] + + _ + [#0 tokens]} + tokens) + parts (: (Maybe [Code (List Code) (Maybe Code) Code]) + ({(#Cons [_ (#Form (#Cons name args))] (#Cons type (#Cons body #Nil))) + (#Some name args (#Some type) body) + + (#Cons name (#Cons type (#Cons body #Nil))) + (#Some name #Nil (#Some type) body) + + (#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil)) + (#Some name args #None body) + + (#Cons name (#Cons body #Nil)) + (#Some name #Nil #None body) + + _ + #None} + tokens'))] + ({(#Some name args ?type body) + (let' [body' ({#Nil + body + + _ + (` (function' (~ name) [(~+ args)] (~ body)))} + args) + body'' ({(#Some type) + (` (: (~ type) (~ body'))) + + #None + body'} + ?type)] + (return (list (` ("lux def" (~ name) + (~ body'') + [(~ location_code) + (#.Record #.Nil)] + (~ (bit$ export?))))))) + + #None + (fail "Wrong syntax for def'")} + parts))) + +(def:' (rejoin_pair pair) + (-> [Code Code] (List Code)) + (let' [[left right] pair] + (list left right))) + +(def:' (text\encode original) + (-> Text Text) + ($_ text\compose ..double_quote original ..double_quote)) + +(def:' (code\encode code) + (-> Code Text) + ({[_ (#Bit value)] + (bit\encode value) + + [_ (#Nat value)] + (nat\encode value) + + [_ (#Int value)] + (int\encode value) + + [_ (#Rev value)] + ("lux io error" "@code\encode Undefined behavior.") + + [_ (#Frac value)] + (frac\encode value) + + [_ (#Text value)] + (text\encode value) + + [_ (#Identifier [prefix name])] + (if (text\= "" prefix) + name + ($_ text\compose prefix "." name)) + + [_ (#Tag [prefix name])] + (if (text\= "" prefix) + ($_ text\compose "#" name) + ($_ text\compose "#" prefix "." name)) + + [_ (#Form xs)] + ($_ text\compose "(" (|> xs + (list\map code\encode) + (interpose " ") + list\reverse + (list\fold text\compose "")) ")") + + [_ (#Tuple xs)] + ($_ text\compose "[" (|> xs + (list\map code\encode) + (interpose " ") + list\reverse + (list\fold text\compose "")) "]") + + [_ (#Record kvs)] + ($_ text\compose "{" (|> kvs + (list\map (function' [kv] ({[k v] ($_ text\compose (code\encode k) " " (code\encode v))} + kv))) + (interpose " ") + list\reverse + (list\fold text\compose "")) "}")} + code)) + +(def:' (expander branches) + (-> (List Code) (Meta (List Code))) + ({(#Cons [_ (#Form (#Cons [_ (#Identifier macro_name)] macro_args))] + (#Cons body + branches')) + (do meta_monad + [??? (macro? macro_name)] + (if ??? + (do meta_monad + [init_expansion (macro_expand_once (form$ (list& (identifier$ macro_name) (form$ macro_args) body branches')))] + (expander init_expansion)) + (do meta_monad + [sub_expansion (expander branches')] + (wrap (list& (form$ (list& (identifier$ macro_name) macro_args)) + body + sub_expansion))))) + + (#Cons pattern (#Cons body branches')) + (do meta_monad + [sub_expansion (expander branches')] + (wrap (list& pattern body sub_expansion))) + + #Nil + (do meta_monad [] (wrap (list))) + + _ + (fail ($_ text\compose "'lux.case' expects an even number of tokens: " (|> branches + (list\map code\encode) + (interpose " ") + list\reverse + (list\fold text\compose ""))))} + branches)) + +(macro:' #export (case tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## The pattern-matching macro." ..\n + "## Allows the usage of macros within the patterns to provide custom syntax." ..\n + "(case (: (List Int) (list +1 +2 +3))" ..\n + " " "(#Cons x (#Cons y (#Cons z #Nil)))" ..\n + " " "(#Some ($_ * x y z))" __paragraph + " " "_" ..\n + " " "#None)"))]) + ({(#Cons value branches) + (do meta_monad + [expansion (expander branches)] + (wrap (list (` ((~ (record$ (as_pairs expansion))) (~ value)))))) + + _ + (fail "Wrong syntax for case")} + tokens)) + +(macro:' #export (^ tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Macro-expanding patterns." ..\n + "## It's a special macro meant to be used with 'case'." ..\n + "(case (: (List Int) (list +1 +2 +3))" ..\n + " (^ (list x y z))" ..\n + " (#Some ($_ * x y z))" + __paragraph + " _" ..\n + " #None)"))]) + (case tokens + (#Cons [_ (#Form (#Cons pattern #Nil))] (#Cons body branches)) + (do meta_monad + [pattern+ (macro_expand_all pattern)] + (case pattern+ + (#Cons pattern' #Nil) + (wrap (list& pattern' body branches)) + + _ + (fail "^ can only expand to 1 pattern."))) + + _ + (fail "Wrong syntax for ^ macro"))) + +(macro:' #export (^or tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Or-patterns." ..\n + "## It's a special macro meant to be used with 'case'." ..\n + "(type: Weekday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday #Sunday)" + __paragraph + "(def: (weekend? day)" ..\n + " (-> Weekday Bit)" ..\n + " (case day" ..\n + " (^or #Saturday #Sunday)" ..\n + " #1" + __paragraph + " _" ..\n + " #0))"))]) + (case tokens + (^ (list& [_ (#Form patterns)] body branches)) + (case patterns + #Nil + (fail "^or cannot have 0 patterns") + + _ + (let' [pairs (|> patterns + (list\map (function' [pattern] (list pattern body))) + (list\join))] + (return (list\compose pairs branches)))) + _ + (fail "Wrong syntax for ^or"))) + +(def:' (identifier? code) + (-> Code Bit) + (case code + [_ (#Identifier _)] + #1 + + _ + #0)) + +(macro:' #export (let tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Creates local bindings." ..\n + "## Can (optionally) use pattern-matching macros when binding." ..\n + "(let [x (foo bar)" ..\n + " y (baz quux)]" ..\n + " (op x y))"))]) + (case tokens + (^ (list [_ (#Tuple bindings)] body)) + (if (multiple? 2 (list\size bindings)) + (|> bindings as_pairs list\reverse + (list\fold (: (-> [Code Code] Code Code) + (function' [lr body'] + (let' [[l r] lr] + (if (identifier? l) + (` ({(~ l) (~ body')} (~ r))) + (` (case (~ r) (~ l) (~ body'))))))) + body) + list + return) + (fail "let requires an even number of parts")) + + _ + (fail "Wrong syntax for let"))) + +(macro:' #export (function tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Syntax for creating functions." ..\n + "## Allows for giving the function itself a name, for the sake of recursion." ..\n + "(: (All [a b] (-> a b a))" ..\n + " (function (_ x y) x))" + __paragraph + "(: (All [a b] (-> a b a))" ..\n + " (function (const x y) x))"))]) + (case (: (Maybe [Text Code (List Code) Code]) + (case tokens + (^ (list [_ (#Form (list& [_ (#Identifier ["" name])] head tail))] body)) + (#Some name head tail body) + + _ + #None)) + (#Some g!name head tail body) + (let [g!blank (local_identifier$ "") + nest (: (-> Code (-> Code Code Code)) + (function' [g!name] + (function' [arg body'] + (if (identifier? arg) + (` ([(~ g!name) (~ arg)] (~ body'))) + (` ([(~ g!name) (~ g!blank)] + (.case (~ g!blank) (~ arg) (~ body'))))))))] + (return (list (nest (..local_identifier$ g!name) head + (list\fold (nest g!blank) body (list\reverse tail)))))) + + #None + (fail "Wrong syntax for function"))) + +(def:' (process_def_meta_value code) + (-> Code Code) + (case code + [_ (#Bit value)] + (meta_code ["library/lux" "Bit"] (bit$ value)) + + [_ (#Nat value)] + (meta_code ["library/lux" "Nat"] (nat$ value)) + + [_ (#Int value)] + (meta_code ["library/lux" "Int"] (int$ value)) + + [_ (#Rev value)] + (meta_code ["library/lux" "Rev"] (rev$ value)) + + [_ (#Frac value)] + (meta_code ["library/lux" "Frac"] (frac$ value)) + + [_ (#Text value)] + (meta_code ["library/lux" "Text"] (text$ value)) + + [_ (#Tag [prefix name])] + (meta_code ["library/lux" "Tag"] (` [(~ (text$ prefix)) (~ (text$ name))])) + + (^or [_ (#Form _)] [_ (#Identifier _)]) + code + + [_ (#Tuple xs)] + (|> xs + (list\map process_def_meta_value) + untemplate_list + (meta_code ["library/lux" "Tuple"])) + + [_ (#Record kvs)] + (|> kvs + (list\map (: (-> [Code Code] Code) + (function (_ [k v]) + (` [(~ (process_def_meta_value k)) + (~ (process_def_meta_value v))])))) + untemplate_list + (meta_code ["library/lux" "Record"])) + )) + +(def:' (process_def_meta kvs) + (-> (List [Code Code]) Code) + (untemplate_list (list\map (: (-> [Code Code] Code) + (function (_ [k v]) + (` [(~ (process_def_meta_value k)) + (~ (process_def_meta_value v))]))) + kvs))) + +(def:' (with_func_args args meta) + (-> (List Code) Code Code) + (case args + #Nil + meta + + _ + (` (#.Cons [[(~ location_code) (#.Tag ["library/lux" "func-args"])] + [(~ location_code) (#.Tuple (.list (~+ (list\map (function (_ arg) + (` [(~ location_code) (#.Text (~ (text$ (code\encode arg))))])) + args))))]] + (~ meta))))) + +(def:' (with_type_args args) + (-> (List Code) Code) + (` {#.type-args [(~+ (list\map (function (_ arg) (text$ (code\encode arg))) + args))]})) + +(def:' (export^ tokens) + (-> (List Code) [Bit (List Code)]) + (case tokens + (#Cons [_ (#Tag [_ "export"])] tokens') + [#1 tokens'] + + _ + [#0 tokens])) + +(def:' (export ?) + (-> Bit (List Code)) + (if ? + (list (' #export)) + (list))) + +(macro:' #export (def: tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Defines global constants/functions." ..\n + "(def: (rejoin_pair pair)" ..\n + " (-> [Code Code] (List Code))" ..\n + " (let [[left right] pair]" ..\n + " (list left right)))" + __paragraph + "(def: branching_exponent" ..\n + " Int" ..\n + " +5)"))]) + (let [[exported? tokens'] (export^ tokens) + parts (: (Maybe [Code (List Code) (Maybe Code) Code (List [Code Code])]) + (case tokens' + (^ (list [_ (#Form (#Cons name args))] [_ (#Record meta_kvs)] type body)) + (#Some [name args (#Some type) body meta_kvs]) + + (^ (list name [_ (#Record meta_kvs)] type body)) + (#Some [name #Nil (#Some type) body meta_kvs]) + + (^ (list [_ (#Form (#Cons name args))] [_ (#Record meta_kvs)] body)) + (#Some [name args #None body meta_kvs]) + + (^ (list name [_ (#Record meta_kvs)] body)) + (#Some [name #Nil #None body meta_kvs]) + + (^ (list [_ (#Form (#Cons name args))] type body)) + (#Some [name args (#Some type) body #Nil]) + + (^ (list name type body)) + (#Some [name #Nil (#Some type) body #Nil]) + + (^ (list [_ (#Form (#Cons name args))] body)) + (#Some [name args #None body #Nil]) + + (^ (list name body)) + (#Some [name #Nil #None body #Nil]) + + _ + #None))] + (case parts + (#Some name args ?type body meta) + (let [body (case args + #Nil + body + + _ + (` (function ((~ name) (~+ args)) (~ body)))) + body (case ?type + (#Some type) + (` (: (~ type) (~ body))) + + #None + body) + =meta (process_def_meta meta)] + (return (list (` ("lux def" (~ name) + (~ body) + [(~ location_code) + (#.Record (~ (with_func_args args =meta)))] + (~ (bit$ exported?))))))) + + #None + (fail "Wrong syntax for def:")))) + +(def: (meta_code_add addition meta) + (-> [Code Code] Code Code) + (case [addition meta] + [[name value] [location (#Record pairs)]] + [location (#Record (#Cons [name value] pairs))] + + _ + meta)) + +(def: (meta_code_merge addition base) + (-> Code Code Code) + (case addition + [location (#Record pairs)] + (list\fold meta_code_add base pairs) + + _ + base)) + +(macro:' #export (macro: tokens) + (list [(tag$ ["library/lux" "doc"]) + (text$ ($_ "lux text concat" + "## Macro-definition macro." ..\n + "(macro: #export (name_of tokens)" ..\n + " (case tokens" ..\n + " (^template [<tag>]" ..\n + " [(^ (list [_ (<tag> [prefix name])]))" ..\n + " (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))])" ..\n + " ([#Identifier] [#Tag])" + __paragraph + " _" ..\n + " (fail ''Wrong syntax for name_of'')))"))]) + (let [[exported? tokens] (export^ tokens) + name+args+meta+body?? (: (Maybe [Name (List Code) (List [Code Code]) Code]) + (case tokens + (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] body)) + (#Some [name args (list) body]) + + (^ (list [_ (#Identifier name)] body)) + (#Some [name #Nil (list) body]) + + (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] [_ (#Record meta_rec_parts)] body)) + (#Some [name args meta_rec_parts body]) + + (^ (list [_ (#Identifier name)] [_ (#Record meta_rec_parts)] body)) + (#Some [name #Nil meta_rec_parts body]) + + _ + #None))] + (case name+args+meta+body?? + (#Some [name args meta body]) + (let [name (identifier$ name) + body (case args + #Nil + body + + _ + (` ("lux macro" + (function ((~ name) (~+ args)) (~ body))))) + =meta (process_def_meta meta)] + (return (list (` ("lux def" (~ name) + (~ body) + [(~ location_code) + (#Record (~ =meta))] + (~ (bit$ exported?))))))) + + #None + (fail "Wrong syntax for macro:")))) + +(macro: #export (interface: tokens) + {#.doc (text$ ($_ "lux text concat" + "## Definition of signatures ala ML." ..\n + "(interface: #export (Ord a)" ..\n + " (: (Equivalence a)" ..\n + " eq)" ..\n + " (: (-> a a Bit)" ..\n + " <)" ..\n + " (: (-> a a Bit)" ..\n + " <=)" ..\n + " (: (-> a a Bit)" ..\n + " >)" ..\n + " (: (-> a a Bit)" ..\n + " >=))"))} + (let [[exported? tokens'] (export^ tokens) + ?parts (: (Maybe [Name (List Code) Code (List Code)]) + (case tokens' + (^ (list& [_ (#Form (list& [_ (#Identifier name)] args))] [meta_rec_location (#Record meta_rec_parts)] sigs)) + (#Some name args [meta_rec_location (#Record meta_rec_parts)] sigs) + + (^ (list& [_ (#Identifier name)] [meta_rec_location (#Record meta_rec_parts)] sigs)) + (#Some name #Nil [meta_rec_location (#Record meta_rec_parts)] sigs) + + (^ (list& [_ (#Form (list& [_ (#Identifier name)] args))] sigs)) + (#Some name args (` {}) sigs) + + (^ (list& [_ (#Identifier name)] sigs)) + (#Some name #Nil (` {}) sigs) + + _ + #None))] + (case ?parts + (#Some name args meta sigs) + (do meta_monad + [name+ (normalize name) + sigs' (monad\map meta_monad macro_expand sigs) + members (: (Meta (List [Text Code])) + (monad\map meta_monad + (: (-> Code (Meta [Text Code])) + (function (_ token) + (case token + (^ [_ (#Form (list [_ (#Text "lux type check")] type [_ (#Identifier ["" name])]))]) + (wrap [name type]) + + _ + (fail "Signatures require typed members!")))) + (list\join sigs'))) + #let [[_module _name] name+ + def_name (identifier$ name) + sig_type (record$ (list\map (: (-> [Text Code] [Code Code]) + (function (_ [m_name m_type]) + [(local_tag$ m_name) m_type])) + members)) + sig_meta (meta_code_merge (` {#.sig? #1}) + meta) + usage (case args + #Nil + def_name + + _ + (` ((~ def_name) (~+ args))))]] + (return (list (` (..type: (~+ (export exported?)) (~ usage) (~ sig_meta) (~ sig_type)))))) + + #None + (fail "Wrong syntax for interface:")))) + +(def: (find f xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #Nil + #None + + (#Cons x xs') + (case (f x) + #None + (find f xs') + + (#Some y) + (#Some y)))) + +(template [<name> <form> <message> <doc_msg>] + [(macro: #export (<name> tokens) + {#.doc <doc_msg>} + (case (list\reverse tokens) + (^ (list& last init)) + (return (list (list\fold (: (-> Code Code Code) + (function (_ pre post) (` <form>))) + last + init))) + + _ + (fail <message>)))] + + [and (if (~ pre) (~ post) #0) "'and' requires >=1 clauses." "Short-circuiting 'and': (and #1 #0 #1) ## => #0"] + [or (if (~ pre) #1 (~ post)) "'or' requires >=1 clauses." "Short-circuiting 'or': (or #1 #0 #1) ## => #1"]) + +(def: (index_of part text) + (-> Text Text (Maybe Nat)) + ("lux text index" 0 part text)) + +(def: #export (error! message) + {#.doc (text$ ($_ "lux text concat" + "## Causes an error, with the given error message." ..\n + "(error! ''OH NO!'')"))} + (-> Text Nothing) + ("lux io error" message)) + +(macro: (default tokens state) + {#.doc (text$ ($_ "lux text concat" + "## Allows you to provide a default value that will be used" ..\n + "## if a (Maybe x) value turns out to be #.None." + __paragraph + "(default +20 (#.Some +10)) ## => +10" + __paragraph + "(default +20 #.None) ## => +20"))} + (case tokens + (^ (list else maybe)) + (let [g!temp (: Code [dummy_location (#Identifier ["" ""])]) + code (` (case (~ maybe) + (#.Some (~ g!temp)) + (~ g!temp) + + #.None + (~ else)))] + (#Right [state (list code)])) + + _ + (#Left "Wrong syntax for default"))) + +(def: (text\split_all_with splitter input) + (-> Text Text (List Text)) + (case (..index_of splitter input) + #None + (list input) + + (#Some idx) + (list& ("lux text clip" 0 idx input) + (text\split_all_with splitter + (let [after_offset ("lux i64 +" 1 idx) + after_length ("lux i64 -" + after_offset + ("lux text size" input))] + ("lux text clip" after_offset after_length input)))))) + +(def: (nth idx xs) + (All [a] + (-> Nat (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons x xs') + (if ("lux i64 =" 0 idx) + (#Some x) + (nth ("lux i64 -" 1 idx) xs') + ))) + +(def: (beta_reduce env type) + (-> (List Type) Type Type) + (case type + (#Sum left right) + (#Sum (beta_reduce env left) (beta_reduce env right)) + + (#Product left right) + (#Product (beta_reduce env left) (beta_reduce env right)) + + (#Apply arg func) + (#Apply (beta_reduce env arg) (beta_reduce env func)) + + (#UnivQ ?local_env ?local_def) + (case ?local_env + #Nil + (#UnivQ env ?local_def) + + _ + type) + + (#ExQ ?local_env ?local_def) + (case ?local_env + #Nil + (#ExQ env ?local_def) + + _ + type) + + (#Function ?input ?output) + (#Function (beta_reduce env ?input) (beta_reduce env ?output)) + + (#Parameter idx) + (case (nth idx env) + (#Some parameter) + parameter + + _ + type) + + (#Named name type) + (beta_reduce env type) + + _ + type + )) + +(def: (apply_type type_fn param) + (-> Type Type (Maybe Type)) + (case type_fn + (#UnivQ env body) + (#Some (beta_reduce (list& type_fn param env) body)) + + (#ExQ env body) + (#Some (beta_reduce (list& type_fn param env) body)) + + (#Apply A F) + (do maybe_monad + [type_fn* (apply_type F A)] + (apply_type type_fn* param)) + + (#Named name type) + (apply_type type param) + + _ + #None)) + +(template [<name> <tag>] + [(def: (<name> type) + (-> Type (List Type)) + (case type + (<tag> left right) + (list& left (<name> right)) + + _ + (list type)))] + + [flatten_variant #Sum] + [flatten_tuple #Product] + [flatten_lambda #Function] + ) + +(def: (flatten_app type) + (-> Type [Type (List Type)]) + (case type + (#Apply head func') + (let [[func tail] (flatten_app func')] + [func (#Cons head tail)]) + + _ + [type (list)])) + +(def: (resolve_struct_type type) + (-> Type (Maybe (List Type))) + (case type + (#Product _) + (#Some (flatten_tuple type)) + + (#Apply arg func) + (do maybe_monad + [output (apply_type func arg)] + (resolve_struct_type output)) + + (#UnivQ _ body) + (resolve_struct_type body) + + (#ExQ _ body) + (resolve_struct_type body) + + (#Named name type) + (resolve_struct_type type) + + (#Sum _) + #None + + _ + (#Some (list type)))) + +(def: (find_module name) + (-> Text (Meta Module)) + (function (_ state) + (let [{#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} state] + (case (get name modules) + (#Some module) + (#Right state module) + + _ + (#Left ($_ text\compose "Unknown module: " name)))))) + +(def: get_current_module + (Meta Module) + (do meta_monad + [module_name current_module_name] + (find_module module_name))) + +(def: (resolve_tag [module name]) + (-> Name (Meta [Nat (List Name) Bit Type])) + (do meta_monad + [=module (find_module module) + #let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags_table #types types #module_annotations _ #module_state _} =module]] + (case (get name tags_table) + (#Some output) + (return output) + + _ + (fail (text\compose "Unknown tag: " (name\encode [module name])))))) + +(def: (resolve_type_tags type) + (-> Type (Meta (Maybe [(List Name) (List Type)]))) + (case type + (#Apply arg func) + (resolve_type_tags func) + + (#UnivQ env body) + (resolve_type_tags body) + + (#ExQ env body) + (resolve_type_tags body) + + (#Named [module name] unnamed) + (do meta_monad + [=module (find_module module) + #let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags #types types #module_annotations _ #module_state _} =module]] + (case (get name types) + (#Some [tags exported? (#Named _ _type)]) + (case (resolve_struct_type _type) + (#Some members) + (return (#Some [tags members])) + + _ + (return #None)) + + _ + (resolve_type_tags unnamed))) + + _ + (return #None))) + +(def: get_expected_type + (Meta Type) + (function (_ state) + (let [{#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} state] + (case expected + (#Some type) + (#Right state type) + + #None + (#Left "Not expecting any type."))))) + +(macro: #export (implementation tokens) + {#.doc "Not meant to be used directly. Prefer 'implementation:'."} + (do meta_monad + [tokens' (monad\map meta_monad macro_expand tokens) + struct_type get_expected_type + tags+type (resolve_type_tags struct_type) + tags (: (Meta (List Name)) + (case tags+type + (#Some [tags _]) + (return tags) + + _ + (fail "No tags available for type."))) + #let [tag_mappings (: (List [Text Code]) + (list\map (function (_ tag) [(second tag) (tag$ tag)]) + tags))] + members (monad\map meta_monad + (: (-> Code (Meta [Code Code])) + (function (_ token) + (case token + (^ [_ (#Form (list [_ (#Text "lux def")] [_ (#Identifier "" tag_name)] value meta [_ (#Bit #0)]))]) + (case (get tag_name tag_mappings) + (#Some tag) + (wrap [tag value]) + + _ + (fail (text\compose "Unknown implementation member: " tag_name))) + + _ + (fail "Invalid implementation member.")))) + (list\join tokens'))] + (wrap (list (record$ members))))) + +(def: (text\join_with separator parts) + (-> Text (List Text) Text) + (case parts + #Nil + "" + + (#Cons head tail) + (list\fold (function (_ right left) + ($_ text\compose left separator right)) + head + tail))) + +(macro: #export (implementation: tokens) + {#.doc (text$ ($_ "lux text concat" + "## Definition of structures ala ML." ..\n + "(implementation: #export order (Order Int)" ..\n + " (def: &equivalence equivalence)" ..\n + " (def: (< test subject)" ..\n + " (< test subject))" ..\n + " (def: (<= test subject)" ..\n + " (or (< test subject)" ..\n + " (= test subject)))" ..\n + " (def: (> test subject)" ..\n + " (> test subject))" ..\n + " (def: (>= test subject)" ..\n + " (or (> test subject)" ..\n + " (= test subject))))"))} + (let [[exported? tokens'] (export^ tokens) + ?parts (: (Maybe [Code (List Code) Code Code (List Code)]) + (case tokens' + (^ (list& [_ (#Form (list& name args))] [meta_rec_location (#Record meta_rec_parts)] type definitions)) + (#Some name args type [meta_rec_location (#Record meta_rec_parts)] definitions) + + (^ (list& name [meta_rec_location (#Record meta_rec_parts)] type definitions)) + (#Some name #Nil type [meta_rec_location (#Record meta_rec_parts)] definitions) + + (^ (list& [_ (#Form (list& name args))] type definitions)) + (#Some name args type (` {}) definitions) + + (^ (list& name type definitions)) + (#Some name #Nil type (` {}) definitions) + + _ + #None))] + (case ?parts + (#Some [name args type meta definitions]) + (let [usage (case args + #Nil + name + + _ + (` ((~ name) (~+ args))))] + (return (list (` (..def: (~+ (export exported?)) (~ usage) + (~ (meta_code_merge (` {#.implementation? #1}) + meta)) + (~ type) + (implementation (~+ definitions))))))) + + #None + (fail "Wrong syntax for implementation:")))) + +(def: (function\identity x) (All [a] (-> a a)) x) + +(macro: #export (type: tokens) + {#.doc (text$ ($_ "lux text concat" + "## The type-definition macro." ..\n + "(type: (List a) #Nil (#Cons a (List a)))"))} + (let [[exported? tokens'] (export^ tokens) + [rec? tokens'] (case tokens' + (#Cons [_ (#Tag [_ "rec"])] tokens') + [#1 tokens'] + + _ + [#0 tokens']) + parts (: (Maybe [Text (List Code) (List [Code Code]) (List Code)]) + (case tokens' + (^ (list [_ (#Identifier "" name)] [meta_location (#Record meta_parts)] [type_location (#Record type_parts)])) + (#Some [name #Nil meta_parts (list [type_location (#Record type_parts)])]) + + (^ (list& [_ (#Identifier "" name)] [meta_location (#Record meta_parts)] type_code1 type_codes)) + (#Some [name #Nil meta_parts (#Cons type_code1 type_codes)]) + + (^ (list& [_ (#Identifier "" name)] type_codes)) + (#Some [name #Nil (list) type_codes]) + + (^ (list [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta_location (#Record meta_parts)] [type_location (#Record type_parts)])) + (#Some [name args meta_parts (list [type_location (#Record type_parts)])]) + + (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta_location (#Record meta_parts)] type_code1 type_codes)) + (#Some [name args meta_parts (#Cons type_code1 type_codes)]) + + (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] type_codes)) + (#Some [name args (list) type_codes]) + + _ + #None))] + (case parts + (#Some name args meta type_codes) + (do meta_monad + [type+tags?? (unfold_type_def type_codes) + module_name current_module_name] + (let [type_name (local_identifier$ name) + [type tags??] type+tags?? + type' (: (Maybe Code) + (if rec? + (if (empty? args) + (let [g!param (local_identifier$ "") + prime_name (local_identifier$ name) + type+ (replace_syntax (list [name (` ((~ prime_name) .Nothing))]) type)] + (#Some (` ((All (~ prime_name) [(~ g!param)] (~ type+)) + .Nothing)))) + #None) + (case args + #Nil + (#Some type) + + _ + (#Some (` (.All (~ type_name) [(~+ args)] (~ type))))))) + total_meta (let [meta (process_def_meta meta) + meta (if rec? + (` (#.Cons (~ (flag_meta "type-rec?")) (~ meta))) + meta)] + (` [(~ location_code) + (#.Record (~ meta))]))] + (case type' + (#Some type'') + (let [typeC (` (#.Named [(~ (text$ module_name)) + (~ (text$ name))] + (.type (~ type''))))] + (return (list (case tags?? + (#Some tags) + (` ("lux def type tagged" (~ type_name) + (~ typeC) + (~ total_meta) + [(~+ (list\map text$ tags))] + (~ (bit$ exported?)))) + + _ + (` ("lux def" (~ type_name) + ("lux type check type" + (~ typeC)) + (~ total_meta) + (~ (bit$ exported?)))))))) + + #None + (fail "Wrong syntax for type:")))) + + #None + (fail "Wrong syntax for type:")) + )) + +(template [<name> <to>] + [(def: #export (<name> value) + (-> (I64 Any) <to>) + (:as <to> value))] + + [i64 I64] + [nat Nat] + [int Int] + [rev Rev] + ) + +(type: Referrals + #All + (#Only (List Text)) + (#Exclude (List Text)) + #Ignore + #Nothing) + +(type: Openings + [Text (List Text)]) + +(type: Refer + {#refer_defs Referrals + #refer_open (List Openings)}) + +(type: Importation + {#import_name Text + #import_alias (Maybe Text) + #import_refer Refer}) + +(def: (extract_defs defs) + (-> (List Code) (Meta (List Text))) + (monad\map meta_monad + (: (-> Code (Meta Text)) + (function (_ def) + (case def + [_ (#Identifier ["" name])] + (return name) + + _ + (fail "#only/#+ and #exclude/#- require identifiers.")))) + defs)) + +(def: (parse_referrals tokens) + (-> (List Code) (Meta [Referrals (List Code)])) + (case tokens + (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "+"])] defs))] tokens')) + (^ (list& [_ (#Form (list& [_ (#Tag ["" "only"])] defs))] tokens'))) + (do meta_monad + [defs' (extract_defs defs)] + (wrap [(#Only defs') tokens'])) + + (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "-"])] defs))] tokens')) + (^ (list& [_ (#Form (list& [_ (#Tag ["" "exclude"])] defs))] tokens'))) + (do meta_monad + [defs' (extract_defs defs)] + (wrap [(#Exclude defs') tokens'])) + + (^or (^ (list& [_ (#Tag ["" "*"])] tokens')) + (^ (list& [_ (#Tag ["" "all"])] tokens'))) + (return [#All tokens']) + + (^or (^ (list& [_ (#Tag ["" "_"])] tokens')) + (^ (list& [_ (#Tag ["" "nothing"])] tokens'))) + (return [#Ignore tokens']) + + _ + (return [#Nothing tokens]))) + +(def: (parse_openings parts) + (-> (List Code) (Meta [(List Openings) (List Code)])) + (case parts + #.Nil + (return [#.Nil #.Nil]) + + (^ (list& [_ (#Form (list& [_ (#Text prefix)] structs))] parts')) + (do meta_monad + [structs' (monad\map meta_monad + (function (_ struct) + (case struct + [_ (#Identifier ["" struct_name])] + (return struct_name) + + _ + (fail "Expected all implementations of opening form to be identifiers."))) + structs) + next+remainder (parse_openings parts')] + (let [[next remainder] next+remainder] + (return [(#.Cons [prefix structs'] next) + remainder]))) + + _ + (return [#.Nil parts]))) + +(def: (text\split! at x) + (-> Nat Text [Text Text]) + [("lux text clip" 0 at x) + ("lux text clip" at (|> x "lux text size" ("lux i64 -" at)) x)]) + +(def: (text\split_with token sample) + (-> Text Text (Maybe [Text Text])) + (do ..maybe_monad + [index (..index_of token sample) + #let [[pre post'] (text\split! index sample) + [_ post] (text\split! ("lux text size" token) post')]] + (wrap [pre post]))) + +(def: (replace_all pattern replacement template) + (-> Text Text Text Text) + ((: (-> Text Text Text) + (function (recur left right) + (case (..text\split_with pattern right) + (#.Some [pre post]) + (recur ($_ "lux text concat" left pre replacement) post) + + #.None + ("lux text concat" left right)))) + "" template)) + +(def: contextual_reference "#") +(def: self_reference ".") + +(def: (de_alias context self aliased) + (-> Text Text Text Text) + (|> aliased + (replace_all ..self_reference self) + (replace_all ..contextual_reference context))) + +(def: #export module_separator + "/") + +(def: parallel_hierarchy_sigil + "\") + +(def: (normalize_parallel_path' hierarchy root) + (-> Text Text Text) + (case [(text\split_with ..module_separator hierarchy) + (text\split_with ..parallel_hierarchy_sigil root)] + [(#.Some [_ hierarchy']) + (#.Some ["" root'])] + (normalize_parallel_path' hierarchy' root') + + _ + (case root + "" hierarchy + _ ($_ text\compose root ..module_separator hierarchy)))) + +(def: (normalize_parallel_path hierarchy root) + (-> Text Text (Maybe Text)) + (case (text\split_with ..parallel_hierarchy_sigil root) + (#.Some ["" root']) + (#.Some (normalize_parallel_path' hierarchy root')) + + _ + #.None)) + +(def: (count_relatives relatives input) + (-> Nat Text Nat) + (case ("lux text index" relatives ..module_separator input) + #None + relatives + + (#Some found) + (if ("lux i64 =" relatives found) + (count_relatives ("lux i64 +" 1 relatives) input) + relatives))) + +(def: (list\take amount list) + (All [a] (-> Nat (List a) (List a))) + (case [amount list] + (^or [0 _] [_ #Nil]) + #Nil + + [_ (#Cons head tail)] + (#Cons head (list\take ("lux i64 -" 1 amount) tail)))) + +(def: (list\drop amount list) + (All [a] (-> Nat (List a) (List a))) + (case [amount list] + (^or [0 _] [_ #Nil]) + list + + [_ (#Cons _ tail)] + (list\drop ("lux i64 -" 1 amount) tail))) + +(def: (clean_module nested? relative_root module) + (-> Bit Text Text (Meta Text)) + (case (count_relatives 0 module) + 0 + (return (if nested? + ($_ "lux text concat" relative_root ..module_separator module) + module)) + + relatives + (let [parts (text\split_all_with ..module_separator relative_root) + jumps ("lux i64 -" 1 relatives)] + (if (n/< (list\size parts) jumps) + (let [prefix (|> parts + list\reverse + (list\drop jumps) + list\reverse + (interpose ..module_separator) + (text\join_with "")) + clean ("lux text clip" relatives (|> module "lux text size" ("lux i64 -" relatives)) module) + output (case ("lux text size" clean) + 0 prefix + _ ($_ text\compose prefix ..module_separator clean))] + (return output)) + (fail ($_ "lux text concat" + "Cannot climb the module hierarchy..." ..\n + "Importing module: " module ..\n + " Relative Root: " relative_root ..\n)))))) + +(def: (alter_domain alteration domain import) + (-> Nat Text Importation Importation) + (let [[import_name import_alias import_refer] import + original (text\split_all_with ..module_separator import_name) + truncated (list\drop (.nat alteration) original) + parallel (case domain + "" + truncated + + _ + (list& domain truncated))] + {#import_name (text\join_with ..module_separator parallel) + #import_alias import_alias + #import_refer import_refer})) + +(def: (parse_imports nested? relative_root context_alias imports) + (-> Bit Text Text (List Code) (Meta (List Importation))) + (do meta_monad + [imports' (monad\map meta_monad + (: (-> Code (Meta (List Importation))) + (function (_ token) + (case token + ## Simple + [_ (#Identifier ["" m_name])] + (do meta_monad + [m_name (clean_module nested? relative_root m_name)] + (wrap (list {#import_name m_name + #import_alias #None + #import_refer {#refer_defs #All + #refer_open (list)}}))) + + ## Nested + (^ [_ (#Tuple (list& [_ (#Identifier ["" m_name])] extra))]) + (do meta_monad + [import_name (case (normalize_parallel_path relative_root m_name) + (#.Some parallel_path) + (wrap parallel_path) + + #.None + (clean_module nested? relative_root m_name)) + referral+extra (parse_referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse_openings extra) + #let [[openings extra] openings+extra] + sub_imports (parse_imports #1 import_name context_alias extra)] + (wrap (case [referral openings] + [#Nothing #Nil] + sub_imports + + _ + (list& {#import_name import_name + #import_alias #None + #import_refer {#refer_defs referral + #refer_open openings}} + sub_imports)))) + + (^ [_ (#Tuple (list& [_ (#Text alias)] [_ (#Identifier ["" m_name])] extra))]) + (do meta_monad + [import_name (case (normalize_parallel_path relative_root m_name) + (#.Some parallel_path) + (wrap parallel_path) + + #.None + (clean_module nested? relative_root m_name)) + referral+extra (parse_referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse_openings extra) + #let [[openings extra] openings+extra + de_aliased (de_alias context_alias m_name alias)] + sub_imports (parse_imports #1 import_name de_aliased extra)] + (wrap (case [referral openings] + [#Ignore #Nil] + sub_imports + + _ + (list& {#import_name import_name + #import_alias (#Some de_aliased) + #import_refer {#refer_defs referral + #refer_open openings}} + sub_imports)))) + + ## Unrecognized syntax. + _ + (do meta_monad + [current_module current_module_name] + (fail ($_ text\compose + "Wrong syntax for import @ " current_module + ..\n (code\encode token))))))) + imports)] + (wrap (list\join imports')))) + +(def: (exported_definitions module state) + (-> Text (Meta (List Text))) + (let [[current_module modules] (case state + {#info info #source source #current_module current_module #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} + [current_module modules])] + (case (get module modules) + (#Some =module) + (let [to_alias (list\map (: (-> [Text Global] + (List Text)) + (function (_ [name definition]) + (case definition + (#Left _) + (list) + + (#Right [exported? def_type def_meta def_value]) + (if exported? + (list name) + (list))))) + (let [{#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _} =module] + definitions))] + (#Right state (list\join to_alias))) + + #None + (#Left ($_ text\compose + "Unknown module: " (text\encode module) ..\n + "Current module: " (case current_module + (#Some current_module) + (text\encode current_module) + + #None + "???") ..\n + "Known modules: " (|> modules + (list\map (function (_ [name module]) + (text$ name))) + tuple$ + code\encode)))) + )) + +(def: (filter p xs) + (All [a] (-> (-> a Bit) (List a) (List a))) + (case xs + #Nil + (list) + + (#Cons x xs') + (if (p x) + (#Cons x (filter p xs')) + (filter p xs')))) + +(def: (is_member? cases name) + (-> (List Text) Text Bit) + (let [output (list\fold (function (_ case prev) + (or prev + (text\= case name))) + #0 + cases)] + output)) + +(def: (try_both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #None (f x2) + (#Some y) (#Some y))) + +(def: (find_in_env name state) + (-> Text Lux (Maybe Type)) + (case state + {#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} + (find (: (-> Scope (Maybe Type)) + (function (_ env) + (case env + {#name _ + #inner _ + #locals {#counter _ #mappings locals} + #captured {#counter _ #mappings closure}} + (try_both (find (: (-> [Text [Type Any]] (Maybe Type)) + (function (_ [bname [type _]]) + (if (text\= name bname) + (#Some type) + #None)))) + (: (List [Text [Type Any]]) locals) + (: (List [Text [Type Any]]) closure))))) + scopes))) + +(def: (find_def_type name state) + (-> Name Lux (Maybe Type)) + (let [[v_prefix v_name] name + {#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} state] + (case (get v_prefix modules) + #None + #None + + (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _}) + (case (get v_name definitions) + #None + #None + + (#Some definition) + (case definition + (#Left de_aliased) + (find_def_type de_aliased state) + + (#Right [exported? def_type def_meta def_value]) + (#Some def_type)))))) + +(def: (find_def_value name state) + (-> Name (Meta [Type Any])) + (let [[v_prefix v_name] name + {#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} state] + (case (get v_prefix modules) + #None + (#Left (text\compose "Unknown definition: " (name\encode name))) + + (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _}) + (case (get v_name definitions) + #None + (#Left (text\compose "Unknown definition: " (name\encode name))) + + (#Some definition) + (case definition + (#Left de_aliased) + (find_def_value de_aliased state) + + (#Right [exported? def_type def_meta def_value]) + (#Right [state [def_type def_value]])))))) + +(def: (find_type_var idx bindings) + (-> Nat (List [Nat (Maybe Type)]) (Maybe Type)) + (case bindings + #Nil + #Nil + + (#Cons [var bound] bindings') + (if ("lux i64 =" idx var) + bound + (find_type_var idx bindings')))) + +(def: (find_type full_name) + (-> Name (Meta Type)) + (do meta_monad + [#let [[module name] full_name] + current_module current_module_name] + (function (_ compiler) + (let [temp (if (text\= "" module) + (case (find_in_env name compiler) + (#Some struct_type) + (#Right [compiler struct_type]) + + _ + (case (find_def_type [current_module name] compiler) + (#Some struct_type) + (#Right [compiler struct_type]) + + _ + (#Left ($_ text\compose "Unknown var: " (name\encode full_name))))) + (case (find_def_type full_name compiler) + (#Some struct_type) + (#Right [compiler struct_type]) + + _ + (#Left ($_ text\compose "Unknown var: " (name\encode full_name)))))] + (case temp + (#Right [compiler (#Var type_id)]) + (let [{#info _ #source _ #current_module _ #modules _ + #scopes _ #type_context type_context #host _ + #seed _ #expected _ #location _ #extensions extensions + #scope_type_vars _} compiler + {#ex_counter _ #var_counter _ #var_bindings var_bindings} type_context] + (case (find_type_var type_id var_bindings) + #None + temp + + (#Some actualT) + (#Right [compiler actualT]))) + + _ + temp)) + ))) + +(def: (zip/2 xs ys) + (All [a b] (-> (List a) (List b) (List [a b]))) + (case xs + (#Cons x xs') + (case ys + (#Cons y ys') + (list& [x y] (zip/2 xs' ys')) + + _ + (list)) + + _ + (list))) + +(def: (type\encode type) + (-> Type Text) + (case type + (#Primitive name params) + (case params + #Nil + name + + _ + ($_ text\compose "(" name " " (|> params (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")")) + + (#Sum _) + ($_ text\compose "(| " (|> (flatten_variant type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")") + + (#Product _) + ($_ text\compose "[" (|> (flatten_tuple type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) "]") + + (#Function _) + ($_ text\compose "(-> " (|> (flatten_lambda type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")") + + (#Parameter id) + (nat\encode id) + + (#Var id) + ($_ text\compose "⌈v:" (nat\encode id) "⌋") + + (#Ex id) + ($_ text\compose "⟨e:" (nat\encode id) "⟩") + + (#UnivQ env body) + ($_ text\compose "(All " (type\encode body) ")") + + (#ExQ env body) + ($_ text\compose "(Ex " (type\encode body) ")") + + (#Apply _) + (let [[func args] (flatten_app type)] + ($_ text\compose + "(" (type\encode func) " " + (|> args (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) + ")")) + + (#Named name _) + (name\encode name) + )) + +(macro: #export (^open tokens) + {#.doc (text$ ($_ "lux text concat" + "## Same as the 'open' macro, but meant to be used as a pattern-matching macro for generating local bindings." ..\n + "## Takes an 'alias' text for the generated local bindings." ..\n + "(def: #export (range (^open ''.'') from to)" ..\n + " (All [a] (-> (Enum a) a a (List a)))" ..\n + " (range' <= succ from to))"))} + (case tokens + (^ (list& [_ (#Form (list [_ (#Text alias)]))] body branches)) + (do meta_monad + [g!temp (gensym "temp")] + (wrap (list& g!temp (` (..^open (~ g!temp) (~ (text$ alias)) (~ body))) branches))) + + (^ (list [_ (#Identifier name)] [_ (#Text alias)] body)) + (do meta_monad + [init_type (find_type name) + struct_evidence (resolve_type_tags init_type)] + (case struct_evidence + #None + (fail (text\compose "Can only 'open' structs: " (type\encode init_type))) + + (#Some tags&members) + (do meta_monad + [full_body ((: (-> Name [(List Name) (List Type)] Code (Meta Code)) + (function (recur source [tags members] target) + (let [locals (list\map (function (_ [t_module t_name]) + ["" (de_alias "" t_name alias)]) + tags) + pattern (tuple$ (list\map identifier$ locals))] + (do meta_monad + [enhanced_target (monad\fold meta_monad + (function (_ [m_local m_type] enhanced_target) + (do meta_monad + [m_implementation (resolve_type_tags m_type)] + (case m_implementation + (#Some m_tags&members) + (recur m_local + m_tags&members + enhanced_target) + + #None + (wrap enhanced_target)))) + target + (zip/2 locals members))] + (wrap (` ({(~ pattern) (~ enhanced_target)} (~ (identifier$ source))))))))) + name tags&members body)] + (wrap (list full_body))))) + + _ + (fail "Wrong syntax for ^open"))) + +(macro: #export (cond tokens) + {#.doc (text$ ($_ "lux text concat" + "## Branching structures with multiple test conditions." ..\n + "(cond (even? num) ''even''" ..\n + " (odd? num) ''odd''" + __paragraph + " ## else_branch" ..\n + " ''???'')"))} + (if ("lux i64 =" 0 (n/% 2 (list\size tokens))) + (fail "cond requires an uneven number of arguments.") + (case (list\reverse tokens) + (^ (list& else branches')) + (return (list (list\fold (: (-> [Code Code] Code Code) + (function (_ branch else) + (let [[right left] branch] + (` (if (~ left) (~ right) (~ else)))))) + else + (as_pairs branches')))) + + _ + (fail "Wrong syntax for cond")))) + +(def: (enumeration' idx xs) + (All [a] (-> Nat (List a) (List [Nat a]))) + (case xs + (#Cons x xs') + (#Cons [idx x] (enumeration' ("lux i64 +" 1 idx) xs')) + + #Nil + #Nil)) + +(def: (enumeration xs) + (All [a] (-> (List a) (List [Nat a]))) + (enumeration' 0 xs)) + +(macro: #export (get@ tokens) + {#.doc (text$ ($_ "lux text concat" + "## Accesses the value of a record at a given tag." ..\n + "(get@ #field my_record)" + __paragraph + "## Can also work with multiple levels of nesting:" ..\n + "(get@ [#foo #bar #baz] my_record)" + __paragraph + "## And, if only the slot/path is given, generates an accessor function:" ..\n + "(let [getter (get@ [#foo #bar #baz])]" ..\n + " (getter my_record))"))} + (case tokens + (^ (list [_ (#Tag slot')] record)) + (do meta_monad + [slot (normalize slot') + output (resolve_tag slot) + #let [[idx tags exported? type] output] + g!_ (gensym "_") + g!output (gensym "")] + (case (resolve_struct_type type) + (#Some members) + (let [pattern (record$ (list\map (: (-> [Name [Nat Type]] [Code Code]) + (function (_ [[r_prefix r_name] [r_idx r_type]]) + [(tag$ [r_prefix r_name]) + (if ("lux i64 =" idx r_idx) + g!output + g!_)])) + (zip/2 tags (enumeration members))))] + (return (list (` ({(~ pattern) (~ g!output)} (~ record)))))) + + _ + (fail "get@ can only use records."))) + + (^ (list [_ (#Tuple slots)] record)) + (return (list (list\fold (: (-> Code Code Code) + (function (_ slot inner) + (` (..get@ (~ slot) (~ inner))))) + record + slots))) + + (^ (list selector)) + (do meta_monad + [g!_ (gensym "_") + g!record (gensym "record")] + (wrap (list (` (function ((~ g!_) (~ g!record)) (..get@ (~ selector) (~ g!record))))))) + + _ + (fail "Wrong syntax for get@"))) + +(def: (open_field alias tags my_tag_index [module short] source type) + (-> Text (List Name) Nat Name Code Type (Meta (List Code))) + (do meta_monad + [output (resolve_type_tags type) + g!_ (gensym "g!_") + #let [g!output (local_identifier$ short) + pattern (|> tags + enumeration + (list\map (function (_ [tag_idx tag]) + (if ("lux i64 =" my_tag_index tag_idx) + g!output + g!_))) + tuple$) + source+ (` ({(~ pattern) (~ g!output)} (~ source)))]] + (case output + (#Some [tags' members']) + (do meta_monad + [decls' (monad\map meta_monad + (: (-> [Nat Name Type] (Meta (List Code))) + (function (_ [sub_tag_index sname stype]) + (open_field alias tags' sub_tag_index sname source+ stype))) + (enumeration (zip/2 tags' members')))] + (return (list\join decls'))) + + _ + (return (list (` ("lux def" (~ (local_identifier$ (de_alias "" short alias))) + (~ source+) + [(~ location_code) (#.Record #Nil)] + #0))))))) + +(macro: #export (open: tokens) + {#.doc (text$ ($_ "lux text concat" + "## Opens a implementation and generates a definition for each of its members (including nested members)." + __paragraph + "## For example:" ..\n + "(open: ''i:.'' number)" + __paragraph + "## Will generate:" ..\n + "(def: i:+ (\ number +))" ..\n + "(def: i:- (\ number -))" ..\n + "(def: i:* (\ number *))" ..\n + "..."))} + (case tokens + (^ (list [_ (#Text alias)] struct)) + (case struct + [_ (#Identifier struct_name)] + (do meta_monad + [struct_type (find_type struct_name) + output (resolve_type_tags struct_type) + #let [source (identifier$ struct_name)]] + (case output + (#Some [tags members]) + (do meta_monad + [decls' (monad\map meta_monad (: (-> [Nat Name Type] (Meta (List Code))) + (function (_ [tag_index sname stype]) + (open_field alias tags tag_index sname source stype))) + (enumeration (zip/2 tags members)))] + (return (list\join decls'))) + + _ + (fail (text\compose "Can only 'open:' structs: " (type\encode struct_type))))) + + _ + (do meta_monad + [g!struct (gensym "struct")] + (return (list (` ("lux def" (~ g!struct) (~ struct) + [(~ location_code) (#.Record #Nil)] + #0)) + (` (..open: (~ (text$ alias)) (~ g!struct))))))) + + _ + (fail "Wrong syntax for open:"))) + +(macro: #export (|>> tokens) + {#.doc (text$ ($_ "lux text concat" + "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..\n + "(|>> (list\map int\encode) (interpose '' '') (fold text\compose ''''))" ..\n + "## =>" ..\n + "(function (_ <arg>) (fold text\compose '''' (interpose '' '' (list\map int\encode <arg>))))"))} + (do meta_monad + [g!_ (gensym "_") + g!arg (gensym "arg")] + (return (list (` (function ((~ g!_) (~ g!arg)) (|> (~ g!arg) (~+ tokens)))))))) + +(macro: #export (<<| tokens) + {#.doc (text$ ($_ "lux text concat" + "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..\n + "(<<| (fold text\compose '''') (interpose '' '') (list\map int\encode))" ..\n + "## =>" ..\n + "(function (_ <arg>) (fold text\compose '''' (interpose '' '' (list\map int\encode <arg>))))"))} + (do meta_monad + [g!_ (gensym "_") + g!arg (gensym "arg")] + (return (list (` (function ((~ g!_) (~ g!arg)) (<| (~+ tokens) (~ g!arg)))))))) + +(def: (imported_by? import_name module_name) + (-> Text Text (Meta Bit)) + (do meta_monad + [module (find_module module_name) + #let [{#module_hash _ #module_aliases _ #definitions _ #imports imports #tags _ #types _ #module_annotations _ #module_state _} module]] + (wrap (is_member? imports import_name)))) + +(def: (read_refer module_name options) + (-> Text (List Code) (Meta Refer)) + (do meta_monad + [referral+options (parse_referrals options) + #let [[referral options] referral+options] + openings+options (parse_openings options) + #let [[openings options] openings+options] + current_module current_module_name] + (case options + #Nil + (wrap {#refer_defs referral + #refer_open openings}) + + _ + (fail ($_ text\compose "Wrong syntax for refer @ " current_module + ..\n (|> options + (list\map code\encode) + (interpose " ") + (list\fold text\compose ""))))))) + +(def: (write_refer module_name [r_defs r_opens]) + (-> Text Refer (Meta (List Code))) + (do meta_monad + [current_module current_module_name + #let [test_referrals (: (-> Text (List Text) (List Text) (Meta (List Any))) + (function (_ module_name all_defs referred_defs) + (monad\map meta_monad + (: (-> Text (Meta Any)) + (function (_ _def) + (if (is_member? all_defs _def) + (return []) + (fail ($_ text\compose _def " is not defined in module " module_name " @ " current_module))))) + referred_defs)))] + defs' (case r_defs + #All + (exported_definitions module_name) + + (#Only +defs) + (do meta_monad + [*defs (exported_definitions module_name) + _ (test_referrals module_name *defs +defs)] + (wrap +defs)) + + (#Exclude _defs) + (do meta_monad + [*defs (exported_definitions module_name) + _ (test_referrals module_name *defs _defs)] + (wrap (filter (|>> (is_member? _defs) not) *defs))) + + #Ignore + (wrap (list)) + + #Nothing + (wrap (list))) + #let [defs (list\map (: (-> Text Code) + (function (_ def) + (` ("lux def alias" (~ (local_identifier$ def)) (~ (identifier$ [module_name def])))))) + defs') + openings (|> r_opens + (list\map (: (-> Openings (List Code)) + (function (_ [alias structs]) + (list\map (function (_ name) + (` (open: (~ (text$ alias)) (~ (identifier$ [module_name name]))))) + structs)))) + list\join)]] + (wrap (list\compose defs openings)) + )) + +(macro: #export (refer tokens) + (case tokens + (^ (list& [_ (#Text module_name)] options)) + (do meta_monad + [=refer (read_refer module_name options)] + (write_refer module_name =refer)) + + _ + (fail "Wrong syntax for refer"))) + +(def: (refer_to_code module_name module_alias' [r_defs r_opens]) + (-> Text (Maybe Text) Refer Code) + (let [module_alias (..default module_name module_alias') + localizations (: (List Code) + (case r_defs + #All + (list (' #*)) + + (#Only defs) + (list (form$ (list& (' #+) (list\map local_identifier$ defs)))) + + (#Exclude defs) + (list (form$ (list& (' #-) (list\map local_identifier$ defs)))) + + #Ignore + (list) + + #Nothing + (list))) + openings (list\map (function (_ [alias structs]) + (form$ (list& (text$ (..replace_all ..contextual_reference module_alias alias)) + (list\map local_identifier$ structs)))) + r_opens)] + (` (..refer (~ (text$ module_name)) + (~+ localizations) + (~+ openings))))) + +(macro: #export (module: tokens) + {#.doc (text$ ($_ "lux text concat" + "## Module_definition macro." + __paragraph + "## Can take optional annotations and allows the specification of modules to import." + __paragraph + "## Example" ..\n + "(.module: {#.doc ''Some documentation...''}" ..\n + " [lux #*" ..\n + " [control" ..\n + " [''M'' monad #*]]" ..\n + " [data" ..\n + " maybe" ..\n + " [''.'' name (''#/.'' codec)]]" ..\n + " [macro" ..\n + " code]]" ..\n + " [//" ..\n + " [type (''.'' equivalence)]])"))} + (do meta_monad + [#let [[_meta _imports] (: [(List [Code Code]) (List Code)] + (case tokens + (^ (list& [_ (#Record _meta)] _imports)) + [_meta _imports] + + _ + [(list) tokens]))] + current_module current_module_name + imports (parse_imports #0 current_module "" _imports) + #let [=imports (|> imports + (list\map (: (-> Importation Code) + (function (_ [m_name m_alias =refer]) + (` [(~ (text$ m_name)) (~ (text$ (default "" m_alias)))])))) + tuple$) + =refers (list\map (: (-> Importation Code) + (function (_ [m_name m_alias =refer]) + (refer_to_code m_name m_alias =refer))) + imports) + =module (` ("lux def module" [(~ location_code) + (#.Record (~ (process_def_meta _meta)))] + (~ =imports)))]] + (wrap (#Cons =module =refers)))) + +(macro: #export (\ tokens) + {#.doc (text$ ($_ "lux text concat" + "## Allows accessing the value of a implementation's member." ..\n + "(\ codec encode)" + __paragraph + "## Also allows using that value as a function." ..\n + "(\ codec encode +123)"))} + (case tokens + (^ (list struct [_ (#Identifier member)])) + (return (list (` (let [(^open (~ (text$ ..self_reference))) (~ struct)] (~ (identifier$ member)))))) + + (^ (list& struct member args)) + (return (list (` ((..\ (~ struct) (~ member)) (~+ args))))) + + _ + (fail "Wrong syntax for \"))) + +(macro: #export (set@ tokens) + {#.doc (text$ ($_ "lux text concat" + "## Sets the value of a record at a given tag." ..\n + "(set@ #name ''Lux'' lang)" + __paragraph + "## Can also work with multiple levels of nesting:" ..\n + "(set@ [#foo #bar #baz] value my_record)" + __paragraph + "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..\n + "(let [setter (set@ [#foo #bar #baz] value)] (setter my_record))" ..\n + "(let [setter (set@ [#foo #bar #baz])] (setter value my_record))"))} + (case tokens + (^ (list [_ (#Tag slot')] value record)) + (do meta_monad + [slot (normalize slot') + output (resolve_tag slot) + #let [[idx tags exported? type] output]] + (case (resolve_struct_type type) + (#Some members) + (do meta_monad + [pattern' (monad\map meta_monad + (: (-> [Name [Nat Type]] (Meta [Name Nat Code])) + (function (_ [r_slot_name [r_idx r_type]]) + (do meta_monad + [g!slot (gensym "")] + (return [r_slot_name r_idx g!slot])))) + (zip/2 tags (enumeration members)))] + (let [pattern (record$ (list\map (: (-> [Name Nat Code] [Code Code]) + (function (_ [r_slot_name r_idx r_var]) + [(tag$ r_slot_name) + r_var])) + pattern')) + output (record$ (list\map (: (-> [Name Nat Code] [Code Code]) + (function (_ [r_slot_name r_idx r_var]) + [(tag$ r_slot_name) + (if ("lux i64 =" idx r_idx) + value + r_var)])) + pattern'))] + (return (list (` ({(~ pattern) (~ output)} (~ record))))))) + + _ + (fail "set@ can only use records."))) + + (^ (list [_ (#Tuple slots)] value record)) + (case slots + #Nil + (fail "Wrong syntax for set@") + + _ + (do meta_monad + [bindings (monad\map meta_monad + (: (-> Code (Meta Code)) + (function (_ _) (gensym "temp"))) + slots) + #let [pairs (zip/2 slots bindings) + update_expr (list\fold (: (-> [Code Code] Code Code) + (function (_ [s b] v) + (` (..set@ (~ s) (~ v) (~ b))))) + value + (list\reverse pairs)) + [_ accesses'] (list\fold (: (-> [Code Code] [Code (List (List Code))] [Code (List (List Code))]) + (function (_ [new_slot new_binding] [old_record accesses']) + [(` (get@ (~ new_slot) (~ new_binding))) + (#Cons (list new_binding old_record) accesses')])) + [record (: (List (List Code)) #Nil)] + pairs) + accesses (list\join (list\reverse accesses'))]] + (wrap (list (` (let [(~+ accesses)] + (~ update_expr))))))) + + (^ (list selector value)) + (do meta_monad + [g!_ (gensym "_") + g!record (gensym "record")] + (wrap (list (` (function ((~ g!_) (~ g!record)) + (..set@ (~ selector) (~ value) (~ g!record))))))) + + (^ (list selector)) + (do meta_monad + [g!_ (gensym "_") + g!value (gensym "value") + g!record (gensym "record")] + (wrap (list (` (function ((~ g!_) (~ g!value) (~ g!record)) + (..set@ (~ selector) (~ g!value) (~ g!record))))))) + + _ + (fail "Wrong syntax for set@"))) + +(macro: #export (update@ tokens) + {#.doc (text$ ($_ "lux text concat" + "## Modifies the value of a record at a given tag, based on some function." ..\n + "(update@ #age inc person)" + __paragraph + "## Can also work with multiple levels of nesting:" ..\n + "(update@ [#foo #bar #baz] func my_record)" + __paragraph + "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..\n + "(let [updater (update@ [#foo #bar #baz] func)] (updater my_record))" ..\n + "(let [updater (update@ [#foo #bar #baz])] (updater func my_record))"))} + (case tokens + (^ (list [_ (#Tag slot')] fun record)) + (do meta_monad + [slot (normalize slot') + output (resolve_tag slot) + #let [[idx tags exported? type] output]] + (case (resolve_struct_type type) + (#Some members) + (do meta_monad + [pattern' (monad\map meta_monad + (: (-> [Name [Nat Type]] (Meta [Name Nat Code])) + (function (_ [r_slot_name [r_idx r_type]]) + (do meta_monad + [g!slot (gensym "")] + (return [r_slot_name r_idx g!slot])))) + (zip/2 tags (enumeration members)))] + (let [pattern (record$ (list\map (: (-> [Name Nat Code] [Code Code]) + (function (_ [r_slot_name r_idx r_var]) + [(tag$ r_slot_name) + r_var])) + pattern')) + output (record$ (list\map (: (-> [Name Nat Code] [Code Code]) + (function (_ [r_slot_name r_idx r_var]) + [(tag$ r_slot_name) + (if ("lux i64 =" idx r_idx) + (` ((~ fun) (~ r_var))) + r_var)])) + pattern'))] + (return (list (` ({(~ pattern) (~ output)} (~ record))))))) + + _ + (fail "update@ can only use records."))) + + (^ (list [_ (#Tuple slots)] fun record)) + (case slots + #Nil + (fail "Wrong syntax for update@") + + _ + (do meta_monad + [g!record (gensym "record") + g!temp (gensym "temp")] + (wrap (list (` (let [(~ g!record) (~ record) + (~ g!temp) (get@ [(~+ slots)] (~ g!record))] + (set@ [(~+ slots)] ((~ fun) (~ g!temp)) (~ g!record)))))))) + + (^ (list selector fun)) + (do meta_monad + [g!_ (gensym "_") + g!record (gensym "record")] + (wrap (list (` (function ((~ g!_) (~ g!record)) + (..update@ (~ selector) (~ fun) (~ g!record))))))) + + (^ (list selector)) + (do meta_monad + [g!_ (gensym "_") + g!fun (gensym "fun") + g!record (gensym "record")] + (wrap (list (` (function ((~ g!_) (~ g!fun) (~ g!record)) + (..update@ (~ selector) (~ g!fun) (~ g!record))))))) + + _ + (fail "Wrong syntax for update@"))) + +(macro: #export (^template tokens) + {#.doc (text$ ($_ "lux text concat" + "## It's similar to template, but meant to be used during pattern-matching." ..\n + "(def: (beta_reduce env type)" ..\n + " (-> (List Type) Type Type)" ..\n + " (case type" ..\n + " (#.Primitive name params)" ..\n + " (#.Primitive name (list\map (beta_reduce env) params))" + __paragraph + " (^template [<tag>]" ..\n + " [(<tag> left right)" ..\n + " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..\n + " ([#.Sum] [#.Product])" + __paragraph + " (^template [<tag>]" ..\n + " [(<tag> left right)" ..\n + " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..\n + " ([#.Function] [#.Apply])" + __paragraph + " (^template [<tag>]" ..\n + " [(<tag> old_env def)" ..\n + " (case old_env" ..\n + " #.Nil" ..\n + " (<tag> env def)" + __paragraph + " _" ..\n + " type)])" ..\n + " ([#.UnivQ] [#.ExQ])" + __paragraph + " (#.Parameter idx)" ..\n + " (default type (list.nth idx env))" + __paragraph + " _" ..\n + " type" ..\n + " ))"))} + (case tokens + (^ (list& [_ (#Form (list [_ (#Tuple bindings)] + [_ (#Tuple templates)]))] + [_ (#Form data)] + branches)) + (case (: (Maybe (List Code)) + (do maybe_monad + [bindings' (monad\map maybe_monad get_short bindings) + data' (monad\map maybe_monad tuple->list data)] + (let [num_bindings (list\size bindings')] + (if (every? (|>> ("lux i64 =" num_bindings)) + (list\map list\size data')) + (let [apply (: (-> RepEnv (List Code)) + (function (_ env) (list\map (apply_template env) templates)))] + (|> data' + (list\map (compose apply (make_env bindings'))) + list\join + wrap)) + #None)))) + (#Some output) + (return (list\compose output branches)) + + #None + (fail "Wrong syntax for ^template")) + + _ + (fail "Wrong syntax for ^template"))) + +(def: (find_baseline_column code) + (-> Code Nat) + (case code + (^template [<tag>] + [[[_ _ column] (<tag> _)] + column]) + ([#Bit] + [#Nat] + [#Int] + [#Rev] + [#Frac] + [#Text] + [#Identifier] + [#Tag]) + + (^template [<tag>] + [[[_ _ column] (<tag> parts)] + (list\fold n/min column (list\map find_baseline_column parts))]) + ([#Form] + [#Tuple]) + + [[_ _ column] (#Record pairs)] + (list\fold n/min column + (list\compose (list\map (|>> first find_baseline_column) pairs) + (list\map (|>> second find_baseline_column) pairs))) + )) + +(type: Doc_Fragment + (#Doc_Comment Text) + (#Doc_Example Code)) + +(def: (identify_doc_fragment code) + (-> Code Doc_Fragment) + (case code + [_ (#Text comment)] + (#Doc_Comment comment) + + _ + (#Doc_Example code))) + +(template [<name> <extension> <doc>] + [(def: #export <name> + {#.doc <doc>} + (All [s] (-> (I64 s) (I64 s))) + (|>> (<extension> 1)))] + + [inc "lux i64 +" "Increment function."] + [dec "lux i64 -" "Decrement function."] + ) + +(def: tag\encode + (-> Name Text) + (|>> name\encode (text\compose "#"))) + +(def: (repeat n x) + (All [a] (-> Int a (List a))) + (if ("lux i64 <" n +0) + (#Cons x (repeat ("lux i64 +" -1 n) x)) + #Nil)) + +(def: (location_padding baseline [_ old_line old_column] [_ new_line new_column]) + (-> Nat Location Location Text) + (if ("lux i64 =" old_line new_line) + (text\join_with "" (repeat (.int ("lux i64 -" old_column new_column)) " ")) + (let [extra_lines (text\join_with "" (repeat (.int ("lux i64 -" old_line new_line)) ..\n)) + space_padding (text\join_with "" (repeat (.int ("lux i64 -" baseline new_column)) " "))] + (text\compose extra_lines space_padding)))) + +(def: (text\size x) + (-> Text Nat) + ("lux text size" x)) + +(def: (update_location [file line column] code_text) + (-> Location Text Location) + [file line ("lux i64 +" column (text\size code_text))]) + +(def: (delim_update_location [file line column]) + (-> Location Location) + [file line (inc column)]) + +(def: rejoin_all_pairs + (-> (List [Code Code]) (List Code)) + (|>> (list\map rejoin_pair) list\join)) + +(def: (doc_example->Text prev_location baseline example) + (-> Location Nat Code [Location Text]) + (case example + (^template [<tag> <encode>] + [[new_location (<tag> value)] + (let [as_text (<encode> value)] + [(update_location new_location as_text) + (text\compose (location_padding baseline prev_location new_location) + as_text)])]) + ([#Bit bit\encode] + [#Nat nat\encode] + [#Int int\encode] + [#Frac frac\encode] + [#Text text\encode] + [#Identifier name\encode] + [#Tag tag\encode]) + + (^template [<tag> <open> <close> <prep>] + [[group_location (<tag> parts)] + (let [[group_location' parts_text] (list\fold (function (_ part [last_location text_accum]) + (let [[part_location part_text] (doc_example->Text last_location baseline part)] + [part_location (text\compose text_accum part_text)])) + [(delim_update_location group_location) ""] + (<prep> parts))] + [(delim_update_location group_location') + ($_ text\compose (location_padding baseline prev_location group_location) + <open> + parts_text + <close>)])]) + ([#Form "(" ")" ..function\identity] + [#Tuple "[" "]" ..function\identity] + [#Record "{" "}" rejoin_all_pairs]) + + [new_location (#Rev value)] + ("lux io error" "@doc_example->Text Undefined behavior.") + )) + +(def: (with_baseline baseline [file line column]) + (-> Nat Location Location) + [file line baseline]) + +(def: (doc_fragment->Text fragment) + (-> Doc_Fragment Text) + (case fragment + (#Doc_Comment comment) + (|> comment + (text\split_all_with ..\n) + (list\map (function (_ line) ($_ text\compose "## " line ..\n))) + (text\join_with "")) + + (#Doc_Example example) + (let [baseline (find_baseline_column example) + [location _] example + [_ text] (doc_example->Text (with_baseline baseline location) baseline example)] + (text\compose text __paragraph)))) + +(macro: #export (doc tokens) + {#.doc (text$ ($_ "lux text concat" + "## Creates code documentation, embedding text as comments and properly formatting the forms it's being given." + __paragraph + "## For Example:" ..\n + "(doc ''Allows arbitrary looping, using the 'recur' form to re-start the loop.''" ..\n + " ''Can be used in monadic code to create monadic loops.''" ..\n + " (loop [count +0" ..\n + " x init]" ..\n + " (if (< +10 count)" ..\n + " (recur (inc count) (f x))" ..\n + " x)))"))} + (return (list (` [(~ location_code) + (#.Text (~ (|> tokens + (list\map (|>> identify_doc_fragment doc_fragment->Text)) + (text\join_with "") + text$)))])))) + +(def: (interleave xs ys) + (All [a] (-> (List a) (List a) (List a))) + (case xs + #Nil + #Nil + + (#Cons x xs') + (case ys + #Nil + #Nil + + (#Cons y ys') + (list& x y (interleave xs' ys'))))) + +(def: (type_to_code type) + (-> Type Code) + (case type + (#Primitive name params) + (` (#.Primitive (~ (text$ name)) (~ (untemplate_list (list\map type_to_code params))))) + + (^template [<tag>] + [(<tag> left right) + (` (<tag> (~ (type_to_code left)) (~ (type_to_code right))))]) + ([#.Sum] [#.Product] + [#.Function] + [#.Apply]) + + (^template [<tag>] + [(<tag> id) + (` (<tag> (~ (nat$ id))))]) + ([#.Parameter] [#.Var] [#.Ex]) + + (^template [<tag>] + [(<tag> env type) + (let [env' (untemplate_list (list\map type_to_code env))] + (` (<tag> (~ env') (~ (type_to_code type)))))]) + ([#.UnivQ] [#.ExQ]) + + (#Named [module name] anonymous) + ## TODO: Generate the explicit type definition instead of using + ## the "identifier$" shortcut below. + ## (` (#.Named [(~ (text$ module)) (~ (text$ name))] + ## (~ (type_to_code anonymous)))) + (identifier$ [module name]))) + +(macro: #export (loop tokens) + {#.doc (doc "Allows arbitrary looping, using the 'recur' form to re-start the loop." + "Can be used in monadic code to create monadic loops." + (loop [count +0 + x init] + (if (< +10 count) + (recur (inc count) (f x)) + x)) + + "Loops can also be given custom names." + (loop my_loop + [count +0 + x init] + (if (< +10 count) + (my_loop (inc count) (f x)) + x)))} + (let [?params (case tokens + (^ (list name [_ (#Tuple bindings)] body)) + (#.Some [name bindings body]) + + (^ (list [_ (#Tuple bindings)] body)) + (#.Some [(local_identifier$ "recur") bindings body]) + + _ + #.None)] + (case ?params + (#.Some [name bindings body]) + (let [pairs (as_pairs bindings) + vars (list\map first pairs) + inits (list\map second pairs)] + (if (every? identifier? inits) + (do meta_monad + [inits' (: (Meta (List Name)) + (case (monad\map maybe_monad get_name inits) + (#Some inits') (return inits') + #None (fail "Wrong syntax for loop"))) + init_types (monad\map meta_monad find_type inits') + expected get_expected_type] + (return (list (` (("lux type check" + (-> (~+ (list\map type_to_code init_types)) + (~ (type_to_code expected))) + (function ((~ name) (~+ vars)) + (~ body))) + (~+ inits)))))) + (do meta_monad + [aliases (monad\map meta_monad + (: (-> Code (Meta Code)) + (function (_ _) (gensym ""))) + inits)] + (return (list (` (let [(~+ (interleave aliases inits))] + (.loop (~ name) + [(~+ (interleave vars aliases))] + (~ body))))))))) + + #.None + (fail "Wrong syntax for loop")))) + +(macro: #export (^slots tokens) + {#.doc (doc "Allows you to extract record members as local variables with the same names." + "For example:" + (let [(^slots [#foo #bar #baz]) quux] + (f foo bar baz)))} + (case tokens + (^ (list& [_ (#Form (list [_ (#Tuple (list& hslot' tslots'))]))] body branches)) + (do meta_monad + [slots (: (Meta [Name (List Name)]) + (case (: (Maybe [Name (List Name)]) + (do maybe_monad + [hslot (get_tag hslot') + tslots (monad\map maybe_monad get_tag tslots')] + (wrap [hslot tslots]))) + (#Some slots) + (return slots) + + #None + (fail "Wrong syntax for ^slots"))) + #let [[hslot tslots] slots] + hslot (normalize hslot) + tslots (monad\map meta_monad normalize tslots) + output (resolve_tag hslot) + g!_ (gensym "_") + #let [[idx tags exported? type] output + slot_pairings (list\map (: (-> Name [Text Code]) + (function (_ [module name]) + [name (local_identifier$ name)])) + (list& hslot tslots)) + pattern (record$ (list\map (: (-> Name [Code Code]) + (function (_ [module name]) + (let [tag (tag$ [module name])] + (case (get name slot_pairings) + (#Some binding) [tag binding] + #None [tag g!_])))) + tags))]] + (return (list& pattern body branches))) + + _ + (fail "Wrong syntax for ^slots"))) + +(def: (place_tokens label tokens target) + (-> Text (List Code) Code (Maybe (List Code))) + (case target + (^or [_ (#Bit _)] [_ (#Nat _)] [_ (#Int _)] [_ (#Rev _)] [_ (#Frac _)] [_ (#Text _)] [_ (#Tag _)]) + (#Some (list target)) + + [_ (#Identifier [prefix name])] + (if (and (text\= "" prefix) + (text\= label name)) + (#Some tokens) + (#Some (list target))) + + (^template [<tag>] + [[location (<tag> elems)] + (do maybe_monad + [placements (monad\map maybe_monad (place_tokens label tokens) elems)] + (wrap (list [location (<tag> (list\join placements))])))]) + ([#Tuple] + [#Form]) + + [location (#Record pairs)] + (do maybe_monad + [=pairs (monad\map maybe_monad + (: (-> [Code Code] (Maybe [Code Code])) + (function (_ [slot value]) + (do maybe_monad + [slot' (place_tokens label tokens slot) + value' (place_tokens label tokens value)] + (case [slot' value'] + (^ [(list =slot) (list =value)]) + (wrap [=slot =value]) + + _ + #None)))) + pairs)] + (wrap (list [location (#Record =pairs)]))) + )) + +(macro: #export (with_expansions tokens) + {#.doc (doc "Controlled macro-expansion." + "Bind an arbitraty number of Code nodes resulting from macro-expansion to local bindings." + "Wherever a binding appears, the bound Code nodes will be spliced in there." + (test: "Code operations & implementations" + (with_expansions + [<tests> (template [<expr> <text>] + [(compare <text> (\ Code/encode encode <expr>))] + + [(bit #1) "#1"] + [(int +123) "+123"] + [(frac +123.0) "+123.0"] + [(text "123") "'123'"] + [(tag ["yolo" "lol"]) "#yolo.lol"] + [(identifier ["yolo" "lol"]) "yolo.lol"] + [(form (list (bit #1))) "(#1)"] + [(tuple (list (bit #1))) "[#1]"] + [(record (list [(bit #1) (int +123)])) "{#1 +123}"] + )] + (test_all <tests>))))} + (case tokens + (^ (list& [_ (#Tuple bindings)] bodies)) + (case bindings + (^ (list& [_ (#Identifier ["" var_name])] macro_expr bindings')) + (do meta_monad + [expansion (macro_expand_once macro_expr)] + (case (place_tokens var_name expansion (` (.with_expansions + [(~+ bindings')] + (~+ bodies)))) + (#Some output) + (wrap output) + + _ + (fail "[with_expansions] Improper macro expansion."))) + + #Nil + (return bodies) + + _ + (fail "Wrong syntax for with_expansions")) + + _ + (fail "Wrong syntax for with_expansions"))) + +(def: (flatten_alias type) + (-> Type Type) + (case type + (^template [<name>] + [(#Named ["library/lux" <name>] _) + type]) + (["Bit"] + ["Nat"] + ["Int"] + ["Rev"] + ["Frac"] + ["Text"]) + + (#Named _ type') + (flatten_alias type') + + _ + type)) + +(def: (anti_quote_def name) + (-> Name (Meta Code)) + (do meta_monad + [type+value (find_def_value name) + #let [[type value] type+value]] + (case (flatten_alias type) + (^template [<name> <type> <wrapper>] + [(#Named ["library/lux" <name>] _) + (wrap (<wrapper> (:as <type> value)))]) + (["Bit" Bit bit$] + ["Nat" Nat nat$] + ["Int" Int int$] + ["Rev" Rev rev$] + ["Frac" Frac frac$] + ["Text" Text text$]) + + _ + (fail (text\compose "Cannot anti-quote type: " (name\encode name)))))) + +(def: (anti_quote token) + (-> Code (Meta Code)) + (case token + [_ (#Identifier [def_prefix def_name])] + (if (text\= "" def_prefix) + (do meta_monad + [current_module current_module_name] + (anti_quote_def [current_module def_name])) + (anti_quote_def [def_prefix def_name])) + + (^template [<tag>] + [[meta (<tag> parts)] + (do meta_monad + [=parts (monad\map meta_monad anti_quote parts)] + (wrap [meta (<tag> =parts)]))]) + ([#Form] + [#Tuple]) + + [meta (#Record pairs)] + (do meta_monad + [=pairs (monad\map meta_monad + (: (-> [Code Code] (Meta [Code Code])) + (function (_ [slot value]) + (do meta_monad + [=value (anti_quote value)] + (wrap [slot =value])))) + pairs)] + (wrap [meta (#Record =pairs)])) + + _ + (\ meta_monad return token) + ## TODO: Figure out why this doesn't work: + ## (\ meta_monad wrap token) + )) + +(macro: #export (static tokens) + (case tokens + (^ (list pattern)) + (do meta_monad + [pattern' (anti_quote pattern)] + (wrap (list pattern'))) + + _ + (fail "Wrong syntax for 'static'."))) + +(type: Multi_Level_Case + [Code (List [Code Code])]) + +(def: (case_level^ level) + (-> Code (Meta [Code Code])) + (case level + (^ [_ (#Tuple (list expr binding))]) + (return [expr binding]) + + _ + (return [level (` #1)]) + )) + +(def: (multi_level_case^ levels) + (-> (List Code) (Meta Multi_Level_Case)) + (case levels + #Nil + (fail "Multi-level patterns cannot be empty.") + + (#Cons init extras) + (do meta_monad + [extras' (monad\map meta_monad case_level^ extras)] + (wrap [init extras'])))) + +(def: (multi_level_case$ g!_ [[init_pattern levels] body]) + (-> Code [Multi_Level_Case Code] (List Code)) + (let [inner_pattern_body (list\fold (function (_ [calculation pattern] success) + (let [bind? (case pattern + [_ (#.Identifier _)] + #1 + + _ + #0)] + (` (case (~ calculation) + (~ pattern) + (~ success) + + (~+ (if bind? + (list) + (list g!_ (` #.None)))))))) + (` (#.Some (~ body))) + (: (List [Code Code]) (list\reverse levels)))] + (list init_pattern inner_pattern_body))) + +(macro: #export (^multi tokens) + {#.doc (doc "Multi-level pattern matching." + "Useful in situations where the result of a branch depends on further refinements on the values being matched." + "For example:" + (case (split (size static) uri) + (^multi (#.Some [chunk uri']) [(text\= static chunk) #1]) + (match_uri endpoint? parts' uri') + + _ + (#.Left (format "Static part " (%t static) " does not match URI: " uri))) + + "Short-cuts can be taken when using bit tests." + "The example above can be rewritten as..." + (case (split (size static) uri) + (^multi (#.Some [chunk uri']) (text\= static chunk)) + (match_uri endpoint? parts' uri') + + _ + (#.Left (format "Static part " (%t static) " does not match URI: " uri))))} + (case tokens + (^ (list& [_meta (#Form levels)] body next_branches)) + (do meta_monad + [mlc (multi_level_case^ levels) + #let [initial_bind? (case mlc + [[_ (#.Identifier _)] _] + #1 + + _ + #0)] + expected get_expected_type + g!temp (gensym "temp")] + (let [output (list g!temp + (` ({(#Some (~ g!temp)) + (~ g!temp) + + #None + (case (~ g!temp) + (~+ next_branches))} + ("lux type check" (#.Apply (~ (type_to_code expected)) Maybe) + (case (~ g!temp) + (~+ (multi_level_case$ g!temp [mlc body])) + + (~+ (if initial_bind? + (list) + (list g!temp (` #.None)))))))))] + (wrap output))) + + _ + (fail "Wrong syntax for ^multi"))) + +## TODO: Allow asking the compiler for the name of the definition +## currently being defined. That name can then be fed into +## 'wrong_syntax_error' for easier maintenance of the error_messages. +(def: wrong_syntax_error + (-> Name Text) + (|>> name\encode + (text\compose "Wrong syntax for "))) + +(macro: #export (name_of tokens) + {#.doc (doc "Given an identifier or a tag, gives back a 2 tuple with the prefix and name parts, both as Text." + (name_of #.doc) + "=>" + ["library/lux" "doc"])} + (case tokens + (^template [<tag>] + [(^ (list [_ (<tag> [prefix name])])) + (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))]) + ([#Identifier] [#Tag]) + + _ + (fail (..wrong_syntax_error ["library/lux" "name_of"])))) + +(def: (get_scope_type_vars state) + (Meta (List Nat)) + (case state + {#info info #source source #current_module _ #modules modules + #scopes scopes #type_context types #host host + #seed seed #expected expected #location location #extensions extensions + #scope_type_vars scope_type_vars} + (#Right state scope_type_vars) + )) + +(def: (list_at idx xs) + (All [a] (-> Nat (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons x xs') + (if ("lux i64 =" 0 idx) + (#Some x) + (list_at (dec idx) xs')))) + +(macro: #export ($ tokens) + {#.doc (doc "Allows you to refer to the type-variables in a polymorphic function's type, by their index." + "In the example below, 0 corresponds to the 'a' variable." + (def: #export (from_list list) + (All [a] (-> (List a) (Row a))) + (list\fold add + (: (Row ($ 0)) + empty) + list)))} + (case tokens + (^ (list [_ (#Nat idx)])) + (do meta_monad + [stvs get_scope_type_vars] + (case (list_at idx (list\reverse stvs)) + (#Some var_id) + (wrap (list (` (#Ex (~ (nat$ var_id)))))) + + #None + (fail (text\compose "Indexed-type does not exist: " (nat\encode idx))))) + + _ + (fail (..wrong_syntax_error (name_of ..$))))) + +(def: #export (is? reference sample) + {#.doc (doc "Tests whether the 2 values are identical (not just 'equal')." + "This one should succeed:" + (let [value +5] + (is? value value)) + + "This one should fail:" + (is? +5 (+ +2 +3)))} + (All [a] (-> a a Bit)) + ("lux is" reference sample)) + +(macro: #export (^@ tokens) + {#.doc (doc "Allows you to simultaneously bind and de-structure a value." + (def: (hash (^@ set [Hash<a> _])) + (list\fold (function (_ elem acc) (+ (\ Hash<a> hash elem) acc)) + 0 + (to_list set))))} + (case tokens + (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] pattern))] body branches)) + (let [g!whole (local_identifier$ name)] + (return (list& g!whole + (` (case (~ g!whole) (~ pattern) (~ body))) + branches))) + + _ + (fail (..wrong_syntax_error (name_of ..^@))))) + +(macro: #export (^|> tokens) + {#.doc (doc "Pipes the value being pattern-matched against prior to binding it to a variable." + (case input + (^|> value [inc (% 10) (max 1)]) + (foo value)))} + (case tokens + (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] [_ (#Tuple steps)]))] body branches)) + (let [g!name (local_identifier$ name)] + (return (list& g!name + (` (let [(~ g!name) (|> (~ g!name) (~+ steps))] + (~ body))) + branches))) + + _ + (fail (..wrong_syntax_error (name_of ..^|>))))) + +(macro: #export (:assume tokens) + {#.doc (doc "Coerces the given expression to the type of whatever is expected." + (: Dinosaur (:assume (list +1 +2 +3))))} + (case tokens + (^ (list expr)) + (do meta_monad + [type get_expected_type] + (wrap (list (` ("lux type as" (~ (type_to_code type)) (~ expr)))))) + + _ + (fail (..wrong_syntax_error (name_of ..:assume))))) + +(def: location + {#.doc "The location of the current expression being analyzed."} + (Meta Location) + (function (_ compiler) + (#Right [compiler (get@ #location compiler)]))) + +(macro: #export (undefined tokens) + {#.doc (doc "Meant to be used as a stand-in for functions with undefined implementations." + "Undefined expressions will type-check against everything, so they make good dummy implementations." + "However, if an undefined expression is ever evaluated, it will raise a runtime error." + (def: (square x) + (-> Int Int) + (undefined)))} + (case tokens + #Nil + (do meta_monad + [location ..location + #let [[module line column] location + location ($_ "lux text concat" (text\encode module) "," (nat\encode line) "," (nat\encode column)) + message ($_ "lux text concat" "Undefined behavior @ " location)]] + (wrap (list (` (..error! (~ (text$ message))))))) + + _ + (fail (..wrong_syntax_error (name_of ..undefined))))) + +(macro: #export (:of tokens) + {#.doc (doc "Generates the type corresponding to a given expression." + "Example #1:" + (let [my_num +123] + (:of my_num)) + "==" + Int + "-------------------" + "Example #2:" + (:of +123) + "==" + Int)} + (case tokens + (^ (list [_ (#Identifier var_name)])) + (do meta_monad + [var_type (find_type var_name)] + (wrap (list (type_to_code var_type)))) + + (^ (list expression)) + (do meta_monad + [g!temp (gensym "g!temp")] + (wrap (list (` (let [(~ g!temp) (~ expression)] + (..:of (~ g!temp))))))) + + _ + (fail (..wrong_syntax_error (name_of ..:of))))) + +(def: (parse_complex_declaration tokens) + (-> (List Code) (Meta [[Text (List Text)] (List Code)])) + (case tokens + (^ (list& [_ (#Form (list& [_ (#Identifier ["" name])] args'))] tokens')) + (do meta_monad + [args (monad\map meta_monad + (function (_ arg') + (case arg' + [_ (#Identifier ["" arg_name])] + (wrap arg_name) + + _ + (fail "Could not parse an argument."))) + args')] + (wrap [[name args] tokens'])) + + _ + (fail "Could not parse a complex declaration.") + )) + +(def: (parse_any tokens) + (-> (List Code) (Meta [Code (List Code)])) + (case tokens + (^ (list& token tokens')) + (return [token tokens']) + + _ + (fail "Could not parse anything.") + )) + +(def: (parse_many tokens) + (-> (List Code) (Meta [(List Code) (List Code)])) + (case tokens + (^ (list& head tail)) + (return [tokens (list)]) + + _ + (fail "Could not parse anything.") + )) + +(def: (parse_end tokens) + (-> (List Code) (Meta Any)) + (case tokens + (^ (list)) + (return []) + + _ + (fail "Expected input Codes to be empty.") + )) + +(def: (parse_anns tokens) + (-> (List Code) (Meta [Code (List Code)])) + (case tokens + (^ (list& [_ (#Record _anns)] tokens')) + (return [(record$ _anns) tokens']) + + _ + (return [(' {}) tokens]) + )) + +(macro: #export (template: tokens) + {#.doc (doc "Define macros in the style of template and ^template." + "For simple macros that do not need any fancy features." + (template: (square x) + (* x x)))} + (do meta_monad + [#let [[export? tokens] (export^ tokens)] + name+args|tokens (parse_complex_declaration tokens) + #let [[[name args] tokens] name+args|tokens] + anns|tokens (parse_anns tokens) + #let [[anns tokens] anns|tokens] + input_templates|tokens (parse_many tokens) + #let [[input_templates tokens] input_templates|tokens] + _ (parse_end tokens) + g!tokens (gensym "tokens") + g!compiler (gensym "compiler") + g!_ (gensym "_") + #let [rep_env (list\map (function (_ arg) + [arg (` ((~' ~) (~ (local_identifier$ arg))))]) + args)] + this_module current_module_name] + (wrap (list (` (macro: (~+ (export export?)) + ((~ (local_identifier$ name)) (~ g!tokens) (~ g!compiler)) + (~ anns) + (case (~ g!tokens) + (^ (list (~+ (list\map local_identifier$ args)))) + (#.Right [(~ g!compiler) + (list (~+ (list\map (function (_ template) + (` (`' (~ (replace_syntax rep_env template))))) + input_templates)))]) + + (~ g!_) + (#.Left (~ (text$ (..wrong_syntax_error [this_module name])))) + ))))) + )) + +(macro: #export (as_is tokens compiler) + (#Right [compiler tokens])) + +(macro: #export (char tokens compiler) + (case tokens + (^multi (^ (list [_ (#Text input)])) + (|> input "lux text size" ("lux i64 =" 1))) + (|> input ("lux text char" 0) + nat$ list + [compiler] #Right) + + _ + (#Left (..wrong_syntax_error (name_of ..char))))) + +(def: target + (Meta Text) + (function (_ compiler) + (#Right [compiler (get@ [#info #target] compiler)]))) + +(def: (resolve_target choice) + (-> Code (Meta Text)) + (case choice + [_ (#Text platform)] + (..return platform) + + [_ (#Identifier identifier)] + (do meta_monad + [identifier (..resolve_global_identifier identifier) + type+value (..find_def_value identifier) + #let [[type value] type+value]] + (case (..flatten_alias type) + (^or (#Primitive "#Text" #Nil) + (#Named ["library/lux" "Text"] (#Primitive "#Text" #Nil))) + (wrap (:as ..Text value)) + + _ + (fail ($_ text\compose + "Invalid target platform (must be a value of type Text): " (name\encode identifier) + " : " (..code\encode (..type_to_code type)))))) + + _ + (fail ($_ text\compose + "Invalid target platform syntax: " (..code\encode choice) + ..\n "Must be either a text literal or an identifier.")))) + +(def: (target_pick target options default) + (-> Text (List [Code Code]) (Maybe Code) (Meta (List Code))) + (case options + #Nil + (case default + #.None + (fail ($_ text\compose "No code for target platform: " target)) + + (#.Some default) + (return (list default))) + + (#Cons [key pick] options') + (do meta_monad + [platform (..resolve_target key)] + (if (text\= target platform) + (return (list pick)) + (target_pick target options' default))))) + +(macro: #export (for tokens) + (do meta_monad + [target ..target] + (case tokens + (^ (list [_ (#Record options)])) + (target_pick target options #.None) + + (^ (list [_ (#Record options)] default)) + (target_pick target options (#.Some default)) + + _ + (fail (..wrong_syntax_error (name_of ..for)))))) + +(template [<name> <type> <output>] + [(def: (<name> xy) + (All [a b] (-> [a b] <type>)) + (let [[x y] xy] + <output>))] + + [left a x] + [right b y]) + +(def: (label_code code) + (-> Code (Meta [(List [Code Code]) Code])) + (case code + (^ [ann (#Form (list [_ (#Identifier ["" "~~"])] expansion))]) + (do meta_monad + [g!expansion (gensym "g!expansion")] + (wrap [(list [g!expansion expansion]) g!expansion])) + + (^template [<tag>] + [[ann (<tag> parts)] + (do meta_monad + [=parts (monad\map meta_monad label_code parts)] + (wrap [(list\fold list\compose (list) (list\map left =parts)) + [ann (<tag> (list\map right =parts))]]))]) + ([#Form] [#Tuple]) + + [ann (#Record kvs)] + (do meta_monad + [=kvs (monad\map meta_monad + (function (_ [key val]) + (do meta_monad + [=key (label_code key) + =val (label_code val) + #let [[key_labels key_labelled] =key + [val_labels val_labelled] =val]] + (wrap [(list\compose key_labels val_labels) [key_labelled val_labelled]]))) + kvs)] + (wrap [(list\fold list\compose (list) (list\map left =kvs)) + [ann (#Record (list\map right =kvs))]])) + + _ + (return [(list) code]))) + +(macro: #export (`` tokens) + (case tokens + (^ (list raw)) + (do meta_monad + [=raw (label_code raw) + #let [[labels labelled] =raw]] + (wrap (list (` (with_expansions [(~+ (|> labels + (list\map (function (_ [label expansion]) (list label expansion))) + list\join))] + (~ labelled)))))) + + _ + (fail (..wrong_syntax_error (name_of ..``))) + )) + +(def: (name$ [module name]) + (-> Name Code) + (` [(~ (text$ module)) (~ (text$ name))])) + +(def: (untemplate_list& last inits) + (-> Code (List Code) Code) + (case inits + #Nil + last + + (#Cons [init inits']) + (` (#.Cons (~ init) (~ (untemplate_list& last inits')))))) + +(def: (untemplate_record g!meta untemplate_pattern fields) + (-> Code (-> Code (Meta Code)) + (-> (List [Code Code]) (Meta Code))) + (do meta_monad + [=fields (monad\map meta_monad + (function (_ [key value]) + (do meta_monad + [=key (untemplate_pattern key) + =value (untemplate_pattern value)] + (wrap (` [(~ =key) (~ =value)])))) + fields)] + (wrap (` [(~ g!meta) (#.Record (~ (untemplate_list =fields)))])))) + +(template [<tag> <name>] + [(def: (<name> g!meta untemplate_pattern elems) + (-> Code (-> Code (Meta Code)) + (-> (List Code) (Meta Code))) + (case (list\reverse elems) + (#Cons [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] + inits) + (do meta_monad + [=inits (monad\map meta_monad untemplate_pattern (list\reverse inits))] + (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list& spliced =inits)))]))) + + _ + (do meta_monad + [=elems (monad\map meta_monad untemplate_pattern elems)] + (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list =elems)))])))))] + + [#.Tuple untemplate_tuple] + [#.Form untemplate_form] + ) + +(def: (untemplate_pattern pattern) + (-> Code (Meta Code)) + (do meta_monad + [g!meta (gensym "g!meta")] + (case pattern + (^template [<tag> <gen>] + [[_ (<tag> value)] + (wrap (` [(~ g!meta) (<tag> (~ (<gen> value)))]))]) + ([#.Bit bit$] + [#.Nat nat$] + [#.Int int$] + [#.Rev rev$] + [#.Frac frac$] + [#.Text text$] + [#.Tag name$] + [#.Identifier name$]) + + [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))] + (return unquoted) + + [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] + (fail "Cannot use (~+) inside of ^code unless it is the last element in a form or a tuple.") + + (^template [<tag> <untemplate>] + [[_ (<tag> elems)] + (<untemplate> g!meta untemplate_pattern elems)]) + ([#.Tuple ..untemplate_tuple] + [#.Form ..untemplate_form]) + + [_ (#Record fields)] + (..untemplate_record g!meta untemplate_pattern fields) + ))) + +(macro: #export (^code tokens) + (case tokens + (^ (list& [_meta (#Form (list template))] body branches)) + (do meta_monad + [pattern (untemplate_pattern template)] + (wrap (list& pattern body branches))) + + (^ (list template)) + (do meta_monad + [pattern (untemplate_pattern template)] + (wrap (list pattern))) + + _ + (fail (..wrong_syntax_error (name_of ..^code))))) + +(template [<zero> <one>] + [(def: #export <zero> #0) + (def: #export <one> #1)] + + [false true] + [no yes] + [off on] + ) + +(macro: #export (:let tokens) + (case tokens + (^ (list [_ (#Tuple bindings)] bodyT)) + (if (multiple? 2 (list\size bindings)) + (return (list (` (..with_expansions [(~+ (|> bindings + ..as_pairs + (list\map (function (_ [localT valueT]) + (list localT (` (..as_is (~ valueT)))))) + (list\fold list\compose (list))))] + (~ bodyT))))) + (..fail ":let requires an even number of parts")) + + _ + (..fail (..wrong_syntax_error (name_of ..:let))))) + +(macro: #export (try tokens) + {#.doc (doc (case (try (risky_computation input)) + (#.Right success) + (do_something success) + + (#.Left error) + (recover_from_failure error)))} + (case tokens + (^ (list expression)) + (do meta_monad + [g!_ (gensym "g!_")] + (wrap (list (` ("lux try" + (.function ((~ g!_) (~ g!_)) + (~ expression))))))) + + _ + (..fail (..wrong_syntax_error (name_of ..try))))) diff --git a/stdlib/source/library/lux/abstract/algebra.lux b/stdlib/source/library/lux/abstract/algebra.lux new file mode 100644 index 000000000..8e611b513 --- /dev/null +++ b/stdlib/source/library/lux/abstract/algebra.lux @@ -0,0 +1,17 @@ +(.module: + [library + [lux #* + [control + [functor (#+ Fix)]]]]) + +(type: #export (Algebra f a) + (-> (f a) a)) + +(type: #export (CoAlgebra f a) + (-> a (f a))) + +(type: #export (RAlgebra f a) + (-> (f (& (Fix f) a)) a)) + +(type: #export (RCoAlgebra f a) + (-> a (f (| (Fix f) a)))) diff --git a/stdlib/source/library/lux/abstract/apply.lux b/stdlib/source/library/lux/abstract/apply.lux new file mode 100644 index 000000000..0f63efc65 --- /dev/null +++ b/stdlib/source/library/lux/abstract/apply.lux @@ -0,0 +1,37 @@ +(.module: + [library + [lux #*]] + [// + [monad (#+ Monad)] + ["." functor (#+ Functor)]]) + +(interface: #export (Apply f) + {#.doc "Applicative functors."} + (: (Functor f) + &functor) + (: (All [a b] + (-> (f (-> a b)) (f a) (f b))) + apply)) + +(implementation: #export (compose f-monad f-apply g-apply) + {#.doc "Applicative functor composition."} + (All [F G] + (-> (Monad F) (Apply F) (Apply G) + ## TODO: Replace (All [a] (F (G a))) with (functor.Then F G) + (Apply (All [a] (F (G a)))))) + + (def: &functor (functor.compose (get@ #&functor f-apply) (get@ #&functor g-apply))) + + (def: (apply fgf fgx) + ## TODO: Switch from this version to the one below (in comments) ASAP. + (let [fgf' (\ f-apply apply + (\ f-monad wrap (\ g-apply apply)) + fgf)] + (\ f-apply apply fgf' fgx)) + ## (let [applyF (\ f-apply apply) + ## applyG (\ g-apply apply)] + ## ($_ applyF + ## (\ f-monad wrap applyG) + ## fgf + ## fgx)) + )) diff --git a/stdlib/source/library/lux/abstract/codec.lux b/stdlib/source/library/lux/abstract/codec.lux new file mode 100644 index 000000000..2d734673f --- /dev/null +++ b/stdlib/source/library/lux/abstract/codec.lux @@ -0,0 +1,29 @@ +(.module: + [library + [lux #* + [control + ["." try (#+ Try)]]]] + [// + [monad (#+ do)] + ["." functor]]) + +(interface: #export (Codec m a) + {#.doc "A way to move back-and-forth between a type and an alternative representation for it."} + (: (-> a m) + encode) + (: (-> m (Try a)) + decode)) + +(implementation: #export (compose cb-codec ba-codec) + {#.doc "Codec composition."} + (All [a b c] + (-> (Codec c b) (Codec b a) + (Codec c a))) + (def: encode + (|>> (\ ba-codec encode) + (\ cb-codec encode))) + + (def: (decode cy) + (do try.monad + [by (\ cb-codec decode cy)] + (\ ba-codec decode by)))) diff --git a/stdlib/source/library/lux/abstract/comonad.lux b/stdlib/source/library/lux/abstract/comonad.lux new file mode 100644 index 000000000..362556f50 --- /dev/null +++ b/stdlib/source/library/lux/abstract/comonad.lux @@ -0,0 +1,79 @@ +(.module: + [library + [lux #* + [data + [collection + ["." list ("#\." fold)]]] + [math + [number + ["n" nat]]] + [meta + ["." location]]]] + [// + [functor (#+ Functor)]]) + +(interface: #export (CoMonad w) + {#.doc (doc "CoMonads are the opposite/complement to monads." + "CoMonadic structures are often infinite in size and built upon lazily-evaluated functions.")} + (: (Functor w) + &functor) + (: (All [a] + (-> (w a) a)) + unwrap) + (: (All [a] + (-> (w a) (w (w a)))) + split)) + +(macro: #export (be tokens state) + {#.doc (doc "A co-monadic parallel to the 'do' macro." + (let [square (function (_ n) (* n n))] + (be comonad + [inputs (iterate inc +2)] + (square (head inputs)))))} + (case (: (Maybe [(Maybe Text) Code (List Code) Code]) + (case tokens + (^ (list [_ (#.Record (list [[_ (#.Identifier ["" name])] comonad]))] [_ (#.Tuple bindings)] body)) + (#.Some [(#.Some name) comonad bindings body]) + + (^ (list comonad [_ (#.Tuple bindings)] body)) + (#.Some [#.None comonad bindings body]) + + _ + #.None)) + (#.Some [?name comonad bindings body]) + (if (|> bindings list.size (n.% 2) (n.= 0)) + (let [[module short] (name_of ..be) + gensym (: (-> Text Code) + (|>> ($_ "lux text concat" module " " short " ") [""] #.Identifier [location.dummy])) + g!_ (gensym "_") + g!map (gensym "map") + g!split (gensym "split") + body' (list\fold (: (-> [Code Code] Code Code) + (function (_ binding body') + (let [[var value] binding] + (case var + [_ (#.Tag ["" "let"])] + (` (let (~ value) (~ body'))) + + _ + (` (|> (~ value) (~ g!split) ((~ g!map) (function ((~ g!_) (~ var)) (~ body'))))) + )))) + body + (list.reverse (list.as_pairs bindings)))] + (#.Right [state (list (case ?name + (#.Some name) + (let [name [location.dummy (#.Identifier ["" name])]] + (` ({(~ name) + ({[(~ g!map) (~' unwrap) (~ g!split)] + (~ body')} + (~ name))} + (~ comonad)))) + + #.None + (` ({[(~ g!map) (~' unwrap) (~ g!split)] + (~ body')} + (~ comonad)))))])) + (#.Left "'be' bindings must have an even number of parts.")) + + #.None + (#.Left "Wrong syntax for 'be'"))) diff --git a/stdlib/source/library/lux/abstract/comonad/cofree.lux b/stdlib/source/library/lux/abstract/comonad/cofree.lux new file mode 100644 index 000000000..c0236f079 --- /dev/null +++ b/stdlib/source/library/lux/abstract/comonad/cofree.lux @@ -0,0 +1,28 @@ +(.module: + [library + [lux #*]] + [// (#+ CoMonad) + [// + [functor (#+ Functor)]]]) + +(type: #export (CoFree F a) + {#.doc "The CoFree CoMonad."} + [a (F (CoFree F a))]) + +(implementation: #export (functor dsl) + (All [F] (-> (Functor F) (Functor (CoFree F)))) + + (def: (map f [head tail]) + [(f head) (\ dsl map (map f) tail)])) + +(implementation: #export (comonad dsl) + (All [F] (-> (Functor F) (CoMonad (CoFree F)))) + + (def: &functor (..functor dsl)) + + (def: (unwrap [head tail]) + head) + + (def: (split [head tail]) + [[head tail] + (\ dsl map split tail)])) diff --git a/stdlib/source/library/lux/abstract/enum.lux b/stdlib/source/library/lux/abstract/enum.lux new file mode 100644 index 000000000..e80975172 --- /dev/null +++ b/stdlib/source/library/lux/abstract/enum.lux @@ -0,0 +1,26 @@ +(.module: + [library + [lux #*]] + [// + ["." order (#+ Order)]]) + +(interface: #export (Enum e) + {#.doc "Enumerable types, with a notion of moving forward and backwards through a type's instances."} + (: (Order e) &order) + (: (-> e e) succ) + (: (-> e e) pred)) + +(def: #export (range enum from to) + {#.doc "An inclusive [from, to] range of values."} + (All [a] (-> (Enum a) a a (List a))) + (let [(^open "/\.") enum] + (loop [end to + output #.Nil] + (cond (/\< end from) + (recur (/\pred end) (#.Cons end output)) + + (/\< from end) + (recur (/\succ end) (#.Cons end output)) + + ## (/\= end from) + (#.Cons end output))))) diff --git a/stdlib/source/library/lux/abstract/equivalence.lux b/stdlib/source/library/lux/abstract/equivalence.lux new file mode 100644 index 000000000..bb21f7711 --- /dev/null +++ b/stdlib/source/library/lux/abstract/equivalence.lux @@ -0,0 +1,25 @@ +(.module: + [library + [lux #*]] + [// + [functor + ["." contravariant]]]) + +(interface: #export (Equivalence a) + {#.doc "Equivalence for a type's instances."} + (: (-> a a Bit) + =)) + +(def: #export (rec sub) + (All [a] (-> (-> (Equivalence a) (Equivalence a)) (Equivalence a))) + (implementation + (def: (= left right) + (sub = left right)))) + +(implementation: #export functor + (contravariant.Functor Equivalence) + + (def: (map f equivalence) + (implementation + (def: (= reference sample) + (\ equivalence = (f reference) (f sample)))))) diff --git a/stdlib/source/library/lux/abstract/fold.lux b/stdlib/source/library/lux/abstract/fold.lux new file mode 100644 index 000000000..168d743be --- /dev/null +++ b/stdlib/source/library/lux/abstract/fold.lux @@ -0,0 +1,17 @@ +(.module: + [library + [lux #*]] + [// + [monoid (#+ Monoid)]]) + +(interface: #export (Fold F) + {#.doc "Iterate over a structure's values to build a summary value."} + (: (All [a b] + (-> (-> b a a) a (F b) a)) + fold)) + +(def: #export (with-monoid monoid fold value) + (All [F a] + (-> (Monoid a) (Fold F) (F a) a)) + (let [(^open "/\.") monoid] + (fold /\compose /\identity value))) diff --git a/stdlib/source/library/lux/abstract/functor.lux b/stdlib/source/library/lux/abstract/functor.lux new file mode 100644 index 000000000..fb56625e8 --- /dev/null +++ b/stdlib/source/library/lux/abstract/functor.lux @@ -0,0 +1,45 @@ +(.module: [library + lux]) + +(interface: #export (Functor f) + (: (All [a b] + (-> (-> a b) + (-> (f a) (f b)))) + map)) + +(type: #export (Fix f) + (f (Fix f))) + +(type: #export (Or f g) + (All [a] (| (f a) (g a)))) + +(def: #export (sum (^open "f\.") (^open "g\.")) + (All [F G] (-> (Functor F) (Functor G) (Functor (..Or F G)))) + (implementation + (def: (map f fa|ga) + (case fa|ga + (#.Left fa) + (#.Left (f\map f fa)) + + (#.Right ga) + (#.Right (g\map f ga)))))) + +(type: #export (And f g) + (All [a] (& (f a) (g a)))) + +(def: #export (product (^open "f\.") (^open "g\.")) + (All [F G] (-> (Functor F) (Functor G) (Functor (..And F G)))) + (implementation + (def: (map f [fa ga]) + [(f\map f fa) + (g\map f ga)]))) + +(type: #export (Then f g) + (All [a] (f (g a)))) + +(def: #export (compose (^open "f\.") (^open "g\.")) + {#.doc "Functor composition."} + (All [F G] (-> (Functor F) (Functor G) (Functor (..Then F G)))) + (implementation + (def: (map f fga) + (f\map (g\map f) fga)))) diff --git a/stdlib/source/library/lux/abstract/functor/contravariant.lux b/stdlib/source/library/lux/abstract/functor/contravariant.lux new file mode 100644 index 000000000..db66f1265 --- /dev/null +++ b/stdlib/source/library/lux/abstract/functor/contravariant.lux @@ -0,0 +1,9 @@ +(.module: + [library + [lux #*]]) + +(interface: #export (Functor f) + (: (All [a b] + (-> (-> b a) + (-> (f a) (f b)))) + map)) diff --git a/stdlib/source/library/lux/abstract/hash.lux b/stdlib/source/library/lux/abstract/hash.lux new file mode 100644 index 000000000..2cc18f3e4 --- /dev/null +++ b/stdlib/source/library/lux/abstract/hash.lux @@ -0,0 +1,27 @@ +(.module: + [library + [lux #*]] + [// + ["." equivalence (#+ Equivalence)] + [functor + ["." contravariant]]]) + +(interface: #export (Hash a) + {#.doc (doc "A way to produce hash-codes for a type's instances." + "A necessity when working with some data-structures, such as dictionaries or sets.")} + (: (Equivalence a) + &equivalence) + (: (-> a Nat) + hash)) + +(implementation: #export functor + (contravariant.Functor Hash) + + (def: (map f super) + (implementation + (def: &equivalence + (\ equivalence.functor map f + (\ super &equivalence))) + + (def: hash + (|>> f (\ super hash)))))) diff --git a/stdlib/source/library/lux/abstract/interval.lux b/stdlib/source/library/lux/abstract/interval.lux new file mode 100644 index 000000000..5fbf26109 --- /dev/null +++ b/stdlib/source/library/lux/abstract/interval.lux @@ -0,0 +1,194 @@ +## https://en.wikipedia.org/wiki/Interval_(mathematics) +(.module: + [library + [lux #*]] + [// + [equivalence (#+ Equivalence)] + ["." order] + [enum (#+ Enum)]]) + +(interface: #export (Interval a) + {#.doc "A representation of top and bottom boundaries for an ordered type."} + (: (Enum a) + &enum) + + (: a + bottom) + + (: a + top)) + +(def: #export (between enum bottom top) + (All [a] (-> (Enum a) a a (Interval a))) + (implementation + (def: &enum enum) + (def: bottom bottom) + (def: top top))) + +(def: #export (singleton enum elem) + (All [a] (-> (Enum a) a (Interval a))) + (implementation + (def: &enum enum) + (def: bottom elem) + (def: top elem))) + +(template [<name> <comp>] + [(def: #export (<name> interval) + (All [a] (-> (Interval a) Bit)) + (let [(^open ",\.") interval] + (<comp> ,\bottom ,\top)))] + + [inner? (order.> ,\&order)] + [outer? ,\<] + [singleton? ,\=] + ) + +(def: #export (within? interval elem) + (All [a] (-> (Interval a) a Bit)) + (let [(^open ",\.") interval] + (cond (inner? interval) + (and (order.>= ,\&order ,\bottom elem) + (order.<= ,\&order ,\top elem)) + + (outer? interval) + (or (order.>= ,\&order ,\bottom elem) + (order.<= ,\&order ,\top elem)) + + ## singleton + (and (,\= ,\bottom elem) + (,\= ,\top elem))))) + +(template [<name> <limit>] + [(def: #export (<name> elem interval) + (All [a] (-> a (Interval a) Bit)) + (let [(^open ".") interval] + (= <limit> elem)))] + + [starts_with? bottom] + [ends_with? top] + ) + +(def: #export (borders? interval elem) + (All [a] (-> (Interval a) a Bit)) + (or (starts_with? elem interval) + (ends_with? elem interval))) + +(def: #export (union left right) + (All [a] (-> (Interval a) (Interval a) (Interval a))) + (implementation + (def: &enum (get@ #&enum right)) + (def: bottom (order.min (\ right &order) (\ left bottom) (\ right bottom))) + (def: top (order.max (\ right &order) (\ left top) (\ right top))))) + +(def: #export (intersection left right) + (All [a] (-> (Interval a) (Interval a) (Interval a))) + (implementation + (def: &enum (get@ #&enum right)) + (def: bottom (order.max (\ right &order) (\ left bottom) (\ right bottom))) + (def: top (order.min (\ right &order) (\ left top) (\ right top))))) + +(def: #export (complement interval) + (All [a] (-> (Interval a) (Interval a))) + (let [(^open ".") interval] + (implementation + (def: &enum (get@ #&enum interval)) + (def: bottom (succ top)) + (def: top (pred bottom))))) + +(def: #export (precedes? reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (let [(^open ".") reference + limit (\ reference bottom)] + (and (< limit (\ sample bottom)) + (< limit (\ sample top))))) + +(def: #export (succeeds? reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (precedes? sample reference)) + +(template [<name> <comp>] + [(def: #export (<name> reference sample) + (All [a] (-> a (Interval a) Bit)) + (let [(^open ",\.") sample] + (and (<comp> reference ,\bottom) + (<comp> reference ,\top))))] + + [before? ,\<] + [after? (order.> ,\&order)] + ) + +(def: #export (meets? reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (let [(^open ",\.") reference + limit (\ reference bottom)] + (and (,\= limit (\ sample top)) + (order.<= ,\&order limit (\ sample bottom))))) + +(def: #export (touches? reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (or (meets? reference sample) + (meets? sample reference))) + +(template [<name> <eq_side> <ineq> <ineq_side>] + [(def: #export (<name> reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (let [(^open ",\.") reference] + (and (,\= (\ reference <eq_side>) + (\ sample <eq_side>)) + (<ineq> ,\&order + (\ reference <ineq_side>) + (\ sample <ineq_side>)))))] + + [starts? ,\bottom order.<= ,\top] + [finishes? ,\top order.>= ,\bottom] + ) + +(implementation: #export equivalence (All [a] (Equivalence (Interval a))) + (def: (= reference sample) + (let [(^open ",\.") reference] + (and (,\= ,\bottom (\ sample bottom)) + (,\= ,\top (\ sample top)))))) + +(def: #export (nested? reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (cond (or (singleton? sample) + (and (inner? reference) (inner? sample)) + (and (outer? reference) (outer? sample))) + (let [(^open ",\.") reference] + (and (order.>= ,\&order (\ reference bottom) (\ sample bottom)) + (order.<= ,\&order (\ reference top) (\ sample top)))) + + (or (singleton? reference) + (and (inner? reference) (outer? sample))) + #0 + + ## (and (outer? reference) (inner? sample)) + (let [(^open ",\.") reference] + (or (and (order.>= ,\&order (\ reference bottom) (\ sample bottom)) + (order.> ,\&order (\ reference bottom) (\ sample top))) + (and (,\< (\ reference top) (\ sample bottom)) + (order.<= ,\&order (\ reference top) (\ sample top))))) + )) + +(def: #export (overlaps? reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (let [(^open ",\.") reference] + (and (not (\ ..equivalence = reference sample)) + (cond (singleton? sample) + #0 + + (singleton? reference) + (nested? sample reference) + + (or (and (inner? sample) (outer? reference)) + (and (outer? sample) (inner? reference))) + (or (order.>= ,\&order (\ reference bottom) (\ sample top)) + (order.<= ,\&order (\ reference top) (\ sample bottom))) + + ## both inner + (inner? sample) + (inner? (intersection reference sample)) + + ## both outer + (not (nested? reference sample)) + )))) diff --git a/stdlib/source/library/lux/abstract/monad.lux b/stdlib/source/library/lux/abstract/monad.lux new file mode 100644 index 000000000..a99baf75b --- /dev/null +++ b/stdlib/source/library/lux/abstract/monad.lux @@ -0,0 +1,184 @@ +(.module: + [library + [lux #* + [meta + ["." location]]]] + [// + [functor (#+ Functor)]]) + +(def: (list\fold f init xs) + (All [a b] + (-> (-> b a a) a (List b) a)) + (case xs + #.Nil + init + + (#.Cons x xs') + (list\fold f (f x init) xs'))) + +(def: (list\size xs) + (All [a] (-> (List a) Nat)) + (loop [counter 0 + xs xs] + (case xs + #.Nil + counter + + (#.Cons _ xs') + (recur (inc counter) xs')))) + +(def: (reverse xs) + (All [a] + (-> (List a) (List a))) + (list\fold (function (_ head tail) (#.Cons head tail)) + #.Nil + xs)) + +(def: (as_pairs xs) + (All [a] (-> (List a) (List [a a]))) + (case xs + (#.Cons x1 (#.Cons x2 xs')) + (#.Cons [x1 x2] (as_pairs xs')) + + _ + #.Nil)) + +(interface: #export (Monad m) + (: (Functor m) + &functor) + (: (All [a] + (-> a (m a))) + wrap) + (: (All [a] + (-> (m (m a)) (m a))) + join)) + +(macro: #export (do tokens state) + {#.doc (doc "Macro for easy concatenation of monadic operations." + (do monad + [y (f1 x) + z (f2 z)] + (wrap (f3 z))))} + (case (: (Maybe [(Maybe Text) Code (List Code) Code]) + (case tokens + (^ (list [_ (#.Record (list [[_ (#.Identifier ["" name])] monad]))] [_ (#.Tuple bindings)] body)) + (#.Some [(#.Some name) monad bindings body]) + + (^ (list monad [_ (#.Tuple bindings)] body)) + (#.Some [#.None monad bindings body]) + + _ + #.None)) + (#.Some [?name monad bindings body]) + (if (|> bindings list\size .int ("lux i64 %" +2) ("lux i64 =" +0)) + (let [[module short] (name_of ..do) + gensym (: (-> Text Code) + (|>> ($_ "lux text concat" module " " short " ") [""] #.Identifier [location.dummy])) + g!_ (gensym "_") + g!map (gensym "map") + g!join (gensym "join") + body' (list\fold (: (-> [Code Code] Code Code) + (function (_ binding body') + (let [[var value] binding] + (case var + [_ (#.Tag ["" "let"])] + (` (let (~ value) (~ body'))) + + _ + (` (|> (~ value) ((~ g!map) (function ((~ g!_) (~ var)) (~ body'))) (~ g!join))) + )))) + body + (reverse (as_pairs bindings)))] + (#.Right [state (list (case ?name + (#.Some name) + (let [name [location.dummy (#.Identifier ["" name])]] + (` ({(~ name) + ({[(~ g!map) (~' wrap) (~ g!join)] + (~ body')} + (~ name))} + (~ monad)))) + + #.None + (` ({[(~ g!map) (~' wrap) (~ g!join)] + (~ body')} + (~ monad)))))])) + (#.Left "'do' bindings must have an even number of parts.")) + + #.None + (#.Left "Wrong syntax for 'do'"))) + +(def: #export (bind monad f) + (All [! a b] + (-> (Monad !) (-> a (! b)) + (-> (! a) (! b)))) + (|>> (\ monad map f) + (\ monad join))) + +(def: #export (seq monad) + {#.doc "Run all the monadic values in the list and produce a list of the base values."} + (All [M a] + (-> (Monad M) (List (M a)) + (M (List a)))) + (let [(^open "!\.") monad] + (function (recur xs) + (case xs + #.Nil + (!\wrap #.Nil) + + (#.Cons x xs') + (|> x + (!\map (function (_ _x) + (!\map (|>> (#.Cons _x)) (recur xs')))) + !\join))))) + +(def: #export (map monad f) + {#.doc "Apply a monadic function to all values in a list."} + (All [M a b] + (-> (Monad M) (-> a (M b)) (List a) + (M (List b)))) + (let [(^open "!\.") monad] + (function (recur xs) + (case xs + #.Nil + (!\wrap #.Nil) + + (#.Cons x xs') + (|> (f x) + (!\map (function (_ _x) + (!\map (|>> (#.Cons _x)) (recur xs')))) + !\join))))) + +(def: #export (filter monad f) + {#.doc "Filter the values in a list with a monadic function."} + (All [! a b] + (-> (Monad !) (-> a (! Bit)) (List a) + (! (List a)))) + (let [(^open "!\.") monad] + (function (recur xs) + (case xs + #.Nil + (!\wrap #.Nil) + + (#.Cons head xs') + (|> (f head) + (!\map (function (_ verdict) + (!\map (function (_ tail) + (if verdict + (#.Cons head tail) + tail)) + (recur xs')))) + !\join))))) + +(def: #export (fold monad f init xs) + {#.doc "Fold a list with a monadic function."} + (All [M a b] + (-> (Monad M) (-> b a (M a)) a (List b) + (M a))) + (case xs + #.Nil + (\ monad wrap init) + + (#.Cons x xs') + (do monad + [init' (f x init)] + (fold monad f init' xs')))) diff --git a/stdlib/source/library/lux/abstract/monad/free.lux b/stdlib/source/library/lux/abstract/monad/free.lux new file mode 100644 index 000000000..9648fbc8e --- /dev/null +++ b/stdlib/source/library/lux/abstract/monad/free.lux @@ -0,0 +1,68 @@ +(.module: + [library + [lux #*]] + [/// + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad)]]) + +(type: #export (Free F a) + {#.doc "The Free Monad."} + (#Pure a) + (#Effect (F (Free F a)))) + +(implementation: #export (functor dsl) + (All [F] (-> (Functor F) (Functor (Free F)))) + + (def: (map f ea) + (case ea + (#Pure a) + (#Pure (f a)) + + (#Effect value) + (#Effect (\ dsl map (map f) value))))) + +(implementation: #export (apply dsl) + (All [F] (-> (Functor F) (Apply (Free F)))) + + (def: &functor (..functor dsl)) + + (def: (apply ef ea) + (case [ef ea] + [(#Pure f) (#Pure a)] + (#Pure (f a)) + + [(#Pure f) (#Effect fa)] + (#Effect (\ dsl map + (\ (..functor dsl) map f) + fa)) + + [(#Effect ff) _] + (#Effect (\ dsl map + (function (_ f) (apply f ea)) + ff)) + ))) + +(implementation: #export (monad dsl) + (All [F] (-> (Functor F) (Monad (Free F)))) + + (def: &functor (..functor dsl)) + + (def: (wrap a) + (#Pure a)) + + (def: (join efefa) + (case efefa + (#Pure efa) + (case efa + (#Pure a) + (#Pure a) + + (#Effect fa) + (#Effect fa)) + + (#Effect fefa) + (#Effect (\ dsl map + (\ (monad dsl) join) + fefa)) + ))) diff --git a/stdlib/source/library/lux/abstract/monad/indexed.lux b/stdlib/source/library/lux/abstract/monad/indexed.lux new file mode 100644 index 000000000..92db5f045 --- /dev/null +++ b/stdlib/source/library/lux/abstract/monad/indexed.lux @@ -0,0 +1,84 @@ +(.module: + [library + [lux #* + [control + [monad] + ["p" parser + ["s" code (#+ Parser)]]] + [data + [collection + ["." list ("#\." functor fold)]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]]]]) + +(interface: #export (IxMonad m) + (: (All [p a] + (-> a (m p p a))) + wrap) + + (: (All [ii it io vi vo] + (-> (-> vi (m it io vo)) + (m ii it vi) + (m ii io vo))) + bind)) + +(type: Binding [Code Code]) + +(def: binding + (Parser Binding) + (p.and s.any s.any)) + +(type: Context + (#Let (List Binding)) + (#Bind Binding)) + +(def: context + (Parser Context) + (p.or (p.after (s.this! (' #let)) + (s.tuple (p.some binding))) + binding)) + +(def: (pair_list [binding value]) + (All [a] (-> [a a] (List a))) + (list binding value)) + +(def: named_monad + (Parser [(Maybe Text) Code]) + (p.either (s.record (p.and (\ p.monad map (|>> #.Some) + s.local_identifier) + s.any)) + (\ p.monad map (|>> [#.None]) + s.any))) + +(syntax: #export (do {[?name monad] ..named_monad} + {context (s.tuple (p.some context))} + expression) + (macro.with_gensyms [g!_ g!bind] + (let [body (list\fold (function (_ context next) + (case context + (#Let bindings) + (` (let [(~+ (|> bindings + (list\map pair_list) + list.concat))] + (~ next))) + + (#Bind [binding value]) + (` ((~ g!bind) + (.function ((~ g!_) (~ binding)) + (~ next)) + (~ value))))) + expression + (list.reverse context))] + (wrap (list (case ?name + (#.Some name) + (let [name (code.local_identifier name)] + (` (let [(~ name) (~ monad) + {#..wrap (~' wrap) + #..bind (~ g!bind)} (~ name)] + (~ body)))) + + #.None + (` (let [{#..wrap (~' wrap) + #..bind (~ g!bind)} (~ monad)] + (~ body))))))))) diff --git a/stdlib/source/library/lux/abstract/monoid.lux b/stdlib/source/library/lux/abstract/monoid.lux new file mode 100644 index 000000000..87f155848 --- /dev/null +++ b/stdlib/source/library/lux/abstract/monoid.lux @@ -0,0 +1,21 @@ +(.module: + [library + [lux #*]]) + +(interface: #export (Monoid a) + {#.doc (doc "A way to compose values." + "Includes an identity value which does not alter any other value when combined with.")} + (: a + identity) + (: (-> a a a) + compose)) + +(def: #export (compose left right) + (All [l r] (-> (Monoid l) (Monoid r) (Monoid [l r]))) + (implementation + (def: identity + [(\ left identity) (\ right identity)]) + + (def: (compose [lL rL] [lR rR]) + [(\ left compose lL lR) + (\ right compose rL rR)]))) diff --git a/stdlib/source/library/lux/abstract/order.lux b/stdlib/source/library/lux/abstract/order.lux new file mode 100644 index 000000000..3eaafaf3a --- /dev/null +++ b/stdlib/source/library/lux/abstract/order.lux @@ -0,0 +1,58 @@ +(.module: + [library + [lux #* + [control + ["." function]]]] + [// + ["." equivalence (#+ Equivalence)] + [functor + ["." contravariant]]]) + +(interface: #export (Order a) + {#.doc "A signature for types that possess some sense of ordering among their elements."} + + (: (Equivalence a) + &equivalence) + + (: (-> a a Bit) + <) + ) + +(type: #export (Comparison a) + (-> (Order a) a a Bit)) + +(def: #export (<= order parameter subject) + Comparison + (or (\ order < parameter subject) + (\ order = parameter subject))) + +(def: #export (> order parameter subject) + Comparison + (\ order < subject parameter)) + +(def: #export (>= order parameter subject) + Comparison + (or (\ order < subject parameter) + (\ order = subject parameter))) + +(type: #export (Choice a) + (-> (Order a) a a a)) + +(def: #export (min order x y) + Choice + (if (\ order < y x) x y)) + +(def: #export (max order x y) + Choice + (if (\ order < y x) y x)) + +(implementation: #export functor + (contravariant.Functor Order) + + (def: (map f order) + (implementation + (def: &equivalence + (\ equivalence.functor map f (\ order &equivalence))) + + (def: (< reference sample) + (\ order < (f reference) (f sample)))))) diff --git a/stdlib/source/library/lux/abstract/predicate.lux b/stdlib/source/library/lux/abstract/predicate.lux new file mode 100644 index 000000000..205ccc316 --- /dev/null +++ b/stdlib/source/library/lux/abstract/predicate.lux @@ -0,0 +1,61 @@ +(.module: + [library + [lux #* + [control + ["." function]]]] + [// + [monoid (#+ Monoid)] + [functor + ["." contravariant]]]) + +(type: #export (Predicate a) + (-> a Bit)) + +(template [<identity_name> <identity_value> <composition_name> <composition>] + [(def: #export <identity_name> + Predicate + (function.constant <identity_value>)) + + (def: #export (<composition_name> left right) + (All [a] (-> (Predicate a) (Predicate a) (Predicate a))) + (function (_ value) + (<composition> (left value) + (right value))))] + + [none #0 unite or] + [all #1 intersect and] + ) + +(template [<name> <identity> <composition>] + [(implementation: #export <name> + (All [a] (Monoid (Predicate a))) + + (def: identity <identity>) + (def: compose <composition>))] + + [union ..none ..unite] + [intersection ..all ..intersect] + ) + +(def: #export (complement predicate) + (All [a] (-> (Predicate a) (Predicate a))) + (|>> predicate not)) + +(def: #export (difference sub base) + (All [a] (-> (Predicate a) (Predicate a) (Predicate a))) + (function (_ value) + (and (base value) + (not (sub value))))) + +(def: #export (rec predicate) + (All [a] + (-> (-> (Predicate a) (Predicate a)) + (Predicate a))) + (function (recur input) + (predicate recur input))) + +(implementation: #export functor + (contravariant.Functor Predicate) + + (def: (map f fb) + (|>> f fb))) diff --git a/stdlib/source/library/lux/control/concatenative.lux b/stdlib/source/library/lux/control/concatenative.lux new file mode 100644 index 000000000..2143a0c97 --- /dev/null +++ b/stdlib/source/library/lux/control/concatenative.lux @@ -0,0 +1,331 @@ +(.module: + [library + [lux (#- Alias if loop) + ["." meta] + [abstract + ["." monad]] + [data + ["." maybe ("#\." monad)] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." fold functor)]]] + ["." macro (#+ with_gensyms) + ["." code] + [syntax (#+ syntax:) + ["|.|" export] + ["|.|" annotations]]] + [math + [number + ["n" nat] + ["i" int] + ["r" rev] + ["f" frac]]]]] + [// + ["<>" parser ("#\." monad) + ["<c>" code (#+ Parser)]]]) + +(type: Alias [Text Code]) + +(type: Stack + {#bottom (Maybe Nat) + #top (List Code)}) + +(def: aliases^ + (Parser (List Alias)) + (|> (<>.and <c>.local_identifier <c>.any) + <>.some + <c>.record + (<>.default (list)))) + +(def: bottom^ + (Parser Nat) + (<c>.form (<>.after (<c>.this! (` #.Parameter)) <c>.nat))) + +(def: stack^ + (Parser Stack) + (<>.either (<>.and (<>.maybe bottom^) + (<c>.tuple (<>.some <c>.any))) + (<>.and (|> bottom^ (<>\map (|>> #.Some))) + (<>\wrap (list))))) + +(def: (stack_fold tops bottom) + (-> (List Code) Code Code) + (list\fold (function (_ top bottom) + (` [(~ bottom) (~ top)])) + bottom + tops)) + +(def: (singleton expander) + (-> (Meta (List Code)) (Meta Code)) + (monad.do meta.monad + [expansion expander] + (case expansion + (#.Cons singleton #.Nil) + (wrap singleton) + + _ + (meta.fail (format "Cannot expand to more than a single AST/Code node:" text.new_line + (|> expansion (list\map %.code) (text.join_with " "))))))) + +(syntax: #export (=> {aliases aliases^} + {inputs stack^} + {outputs stack^}) + (let [de_alias (function (_ aliased) + (list\fold (function (_ [from to] pre) + (code.replace (code.local_identifier from) to pre)) + aliased + aliases))] + (case [(|> inputs (get@ #bottom) (maybe\map (|>> code.nat (~) #.Parameter (`)))) + (|> outputs (get@ #bottom) (maybe\map (|>> code.nat (~) #.Parameter (`))))] + [(#.Some bottomI) (#.Some bottomO)] + (monad.do meta.monad + [inputC (singleton (macro.expand_all (stack_fold (get@ #top inputs) bottomI))) + outputC (singleton (macro.expand_all (stack_fold (get@ #top outputs) bottomO)))] + (wrap (list (` (-> (~ (de_alias inputC)) + (~ (de_alias outputC))))))) + + [?bottomI ?bottomO] + (with_gensyms [g!stack] + (monad.do meta.monad + [inputC (singleton (macro.expand_all (stack_fold (get@ #top inputs) (maybe.default g!stack ?bottomI)))) + outputC (singleton (macro.expand_all (stack_fold (get@ #top outputs) (maybe.default g!stack ?bottomO))))] + (wrap (list (` (All [(~ g!stack)] + (-> (~ (de_alias inputC)) + (~ (de_alias outputC)))))))))))) + +(def: begin! Any []) + +(def: end! + (All [a] (-> [Any a] a)) + (function (_ [_ top]) + top)) + +(syntax: #export (||> {commands (<>.some <c>.any)}) + (wrap (list (` (|> (~! ..begin!) (~+ commands) ((~! ..end!))))))) + +(syntax: #export (word: + {export |export|.parser} + {name <c>.local_identifier} + {annotations (<>.default |annotations|.empty |annotations|.parser)} + type + {commands (<>.some <c>.any)}) + (wrap (list (` (def: (~+ (|export|.format export)) (~ (code.local_identifier name)) + (~ (|annotations|.format annotations)) + (~ type) + (|>> (~+ commands))))))) + +(syntax: #export (apply {arity (|> <c>.nat (<>.filter (n.> 0)))}) + (with_gensyms [g! g!func g!stack g!output] + (monad.do {! meta.monad} + [g!inputs (|> (macro.gensym "input") (list.repeat arity) (monad.seq !))] + (wrap (list (` (: (All [(~+ g!inputs) (~ g!output)] + (-> (-> (~+ g!inputs) (~ g!output)) + (=> [(~+ g!inputs)] [(~ g!output)]))) + (function ((~ g!) (~ g!func)) + (function ((~ g!) (~ (stack_fold g!inputs g!stack))) + [(~ g!stack) ((~ g!func) (~+ g!inputs))]))))))))) + +(def: #export apply/1 (apply 1)) +(def: #export apply/2 (apply 2)) +(def: #export apply/3 (apply 3)) +(def: #export apply/4 (apply 4)) +(def: #export apply/5 (apply 5)) +(def: #export apply/6 (apply 6)) +(def: #export apply/7 (apply 7)) +(def: #export apply/8 (apply 8)) + +(def: #export (push x) + (All [a] (-> a (=> [] [a]))) + (function (_ stack) + [stack x])) + +(def: #export drop + (All [t] (=> [t] [])) + (function (_ [stack top]) + stack)) + +(def: #export nip + (All [_ a] (=> [_ a] [a])) + (function (_ [[stack _] top]) + [stack top])) + +(def: #export dup + (All [a] (=> [a] [a a])) + (function (_ [stack top]) + [[stack top] top])) + +(def: #export swap + (All [a b] (=> [a b] [b a])) + (function (_ [[stack l] r]) + [[stack r] l])) + +(def: #export rotL + (All [a b c] (=> [a b c] [b c a])) + (function (_ [[[stack a] b] c]) + [[[stack b] c] a])) + +(def: #export rotR + (All [a b c] (=> [a b c] [c a b])) + (function (_ [[[stack a] b] c]) + [[[stack c] a] b])) + +(def: #export && + (All [a b] (=> [a b] [(& a b)])) + (function (_ [[stack l] r]) + [stack [l r]])) + +(def: #export ||L + (All [a b] (=> [a] [(| a b)])) + (function (_ [stack l]) + [stack (0 #0 l)])) + +(def: #export ||R + (All [a b] (=> [b] [(| a b)])) + (function (_ [stack r]) + [stack (0 #1 r)])) + +(template [<input> <output> <word> <func>] + [(def: #export <word> + (=> [<input> <input>] [<output>]) + (function (_ [[stack subject] param]) + [stack (<func> param subject)]))] + + [Nat Nat n/+ n.+] + [Nat Nat n/- n.-] + [Nat Nat n/* n.*] + [Nat Nat n// n./] + [Nat Nat n/% n.%] + [Nat Bit n/= n.=] + [Nat Bit n/< n.<] + [Nat Bit n/<= n.<=] + [Nat Bit n/> n.>] + [Nat Bit n/>= n.>=] + + [Int Int i/+ i.+] + [Int Int i/- i.-] + [Int Int i/* i.*] + [Int Int i// i./] + [Int Int i/% i.%] + [Int Bit i/= i.=] + [Int Bit i/< i.<] + [Int Bit i/<= i.<=] + [Int Bit i/> i.>] + [Int Bit i/>= i.>=] + + [Rev Rev r/+ r.+] + [Rev Rev r/- r.-] + [Rev Rev r/* r.*] + [Rev Rev r// r./] + [Rev Rev r/% r.%] + [Rev Bit r/= r.=] + [Rev Bit r/< r.<] + [Rev Bit r/<= r.<=] + [Rev Bit r/> r.>] + [Rev Bit r/>= r.>=] + + [Frac Frac f/+ f.+] + [Frac Frac f/- f.-] + [Frac Frac f/* f.*] + [Frac Frac f// f./] + [Frac Frac f/% f.%] + [Frac Bit f/= f.=] + [Frac Bit f/< f.<] + [Frac Bit f/<= f.<=] + [Frac Bit f/> f.>] + [Frac Bit f/>= f.>=] + ) + +(def: #export if + (All [___a ___z] + (=> {then (=> ___a ___z) + else (=> ___a ___z)} + ___a [Bit then else] ___z)) + (function (_ [[[stack test] then] else]) + (.if test + (then stack) + (else stack)))) + +(def: #export call + (All [___a ___z] + (=> {quote (=> ___a ___z)} + ___a [quote] ___z)) + (function (_ [stack quote]) + (quote stack))) + +(def: #export loop + (All [___] + (=> {test (=> ___ ___ [Bit])} + ___ [test] ___)) + (function (loop [stack pred]) + (let [[stack' verdict] (pred stack)] + (.if verdict + (loop [stack' pred]) + stack')))) + +(def: #export dip + (All [___ a] + (=> ___ [a (=> ___ ___)] + ___ [a])) + (function (_ [[stack a] quote]) + [(quote stack) a])) + +(def: #export dip/2 + (All [___ a b] + (=> ___ [a b (=> ___ ___)] + ___ [a b])) + (function (_ [[[stack a] b] quote]) + [[(quote stack) a] b])) + +(def: #export do + (All [___a ___z] + (=> {body (=> ___a ___z) + pred (=> ___z ___a [Bit])} + ___a [pred body] + ___z [pred body])) + (function (_ [[stack pred] body]) + [[(body stack) pred] body])) + +(def: #export while + (All [___a ___z] + (=> {body (=> ___z ___a) + pred (=> ___a ___z [Bit])} + ___a [pred body] + ___z)) + (function (while [[stack pred] body]) + (let [[stack' verdict] (pred stack)] + (.if verdict + (while [[(body stack') pred] body]) + stack')))) + +(def: #export compose + (All [___a ___ ___z] + (=> [(=> ___a ___) (=> ___ ___z)] + [(=> ___a ___z)])) + (function (_ [[stack f] g]) + [stack (|>> f g)])) + +(def: #export curry + (All [___a ___z a] + (=> ___a [a (=> ___a [a] ___z)] + ___a [(=> ___a ___z)])) + (function (_ [[stack arg] quote]) + [stack (|>> (push arg) quote)])) + +(word: #export when + (All [___] + (=> {body (=> ___ ___)} + ___ [Bit body] + ___)) + swap + (push (|>> call)) + (push (|>> drop)) + if) + +(word: #export ? + (All [a] + (=> [Bit a a] [a])) + rotL + (push (|>> drop)) + (push (|>> nip)) + if) diff --git a/stdlib/source/library/lux/control/concurrency/actor.lux b/stdlib/source/library/lux/control/concurrency/actor.lux new file mode 100644 index 000000000..a12e65471 --- /dev/null +++ b/stdlib/source/library/lux/control/concurrency/actor.lux @@ -0,0 +1,390 @@ +(.module: {#.doc "The actor model of concurrency."} + [library + [lux #* + [abstract + monad] + [control + [pipe (#+ case>)] + ["." function] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["." io (#+ IO io)] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." monoid monad fold)]]] + ["." macro (#+ with_gensyms) + ["." code] + [syntax (#+ syntax:) + ["|.|" input] + ["|.|" export] + ["|.|" annotations]]] + [math + [number + ["n" nat]]] + ["." meta (#+ monad) + ["." annotation]] + [type (#+ :share) + ["." abstract (#+ abstract: :representation :abstraction)]]]] + [// + ["." atom (#+ Atom atom)] + ["." promise (#+ Promise Resolver) ("#\." monad)] + ["." frp (#+ Channel)]]) + +(exception: #export poisoned) +(exception: #export dead) + +(with_expansions + [<Mail> (as_is (-> s (Actor s) (Promise (Try s)))) + <Obituary> (as_is [Text s (List <Mail>)]) + <Mailbox> (as_is (Rec Mailbox + [(Promise [<Mail> Mailbox]) + (Resolver [<Mail> Mailbox])]))] + + (def: (pending [read write]) + (All [a] + (-> (Rec Mailbox + [(Promise [a Mailbox]) + (Resolver [a Mailbox])]) + (IO (List a)))) + (do {! io.monad} + [current (promise.poll read)] + (case current + (#.Some [head tail]) + (\ ! map (|>> (#.Cons head)) + (pending tail)) + + #.None + (wrap #.Nil)))) + + (abstract: #export (Actor s) + {#obituary [(Promise <Obituary>) + (Resolver <Obituary>)] + #mailbox (Atom <Mailbox>)} + + (type: #export (Mail s) + <Mail>) + + (type: #export (Obituary s) + <Obituary>) + + (type: #export (Behavior o s) + {#.doc "An actor's behavior when mail is received and when a fatal error occurs."} + {#on_init (-> o s) + #on_mail (-> (Mail s) s (Actor s) (Promise (Try s)))}) + + (def: #export (spawn! behavior init) + {#.doc "Given a behavior and initial state, spawns an actor and returns it."} + (All [o s] (-> (Behavior o s) o (IO (Actor s)))) + (io (let [[on_init on_mail] behavior + self (:share [o s] + (Behavior o s) + behavior + + (Actor s) + (:abstraction {#obituary (promise.promise []) + #mailbox (atom (promise.promise []))})) + process (loop [state (on_init init) + [|mailbox| _] (io.run (atom.read (get@ #mailbox (:representation self))))] + (do {! promise.monad} + [[head tail] |mailbox| + ?state' (on_mail head state self)] + (case ?state' + (#try.Failure error) + (let [[_ resolve] (get@ #obituary (:representation self))] + (exec (io.run + (do io.monad + [pending (..pending tail)] + (resolve [error state (#.Cons head pending)]))) + (wrap []))) + + (#try.Success state') + (recur state' tail))))] + self))) + + (def: #export (alive? actor) + (All [s] (-> (Actor s) (IO Bit))) + (let [[obituary _] (get@ #obituary (:representation actor))] + (|> obituary + promise.poll + (\ io.functor map + (|>> (case> #.None + yes + + _ + no)))))) + + (def: #export (obituary actor) + (All [s] (-> (Actor s) (IO (Maybe (Obituary s))))) + (let [[obituary _] (get@ #obituary (:representation actor))] + (promise.poll obituary))) + + (def: #export await + (All [s] (-> (Actor s) (Promise (Obituary s)))) + (|>> :representation + (get@ #obituary) + product.left)) + + (def: #export (mail! mail actor) + {#.doc "Send mail to an actor.."} + (All [s] (-> (Mail s) (Actor s) (IO (Try Any)))) + (do {! io.monad} + [alive? (..alive? actor)] + (if alive? + (let [entry [mail (promise.promise [])]] + (do ! + [|mailbox|&resolve (atom.read (get@ #mailbox (:representation actor)))] + (loop [[|mailbox| resolve] |mailbox|&resolve] + (do ! + [|mailbox| (promise.poll |mailbox|)] + (case |mailbox| + #.None + (do ! + [resolved? (resolve entry)] + (if resolved? + (do ! + [_ (atom.write (product.right entry) (get@ #mailbox (:representation actor)))] + (wrap (exception.return []))) + (recur |mailbox|&resolve))) + + (#.Some [_ |mailbox|']) + (recur |mailbox|')))))) + (wrap (exception.throw ..dead []))))) + + (type: #export (Message s o) + (-> s (Actor s) (Promise (Try [s o])))) + + (def: (mail message) + (All [s o] (-> (Message s o) [(Promise (Try o)) (Mail s)])) + (let [[promise resolve] (:share [s o] + (Message s o) + message + + [(Promise (Try o)) + (Resolver (Try o))] + (promise.promise []))] + [promise + (function (_ state self) + (do {! promise.monad} + [outcome (message state self)] + (case outcome + (#try.Success [state' return]) + (exec (io.run (resolve (#try.Success return))) + (promise.resolved (#try.Success state'))) + + (#try.Failure error) + (exec (io.run (resolve (#try.Failure error))) + (promise.resolved (#try.Failure error))))))])) + + (def: #export (tell! message actor) + {#.doc "Communicate with an actor through message passing."} + (All [s o] (-> (Message s o) (Actor s) (Promise (Try o)))) + (let [[promise mail] (..mail message)] + (do promise.monad + [outcome (promise.future (..mail! mail actor))] + (case outcome + (#try.Success) + promise + + (#try.Failure error) + (wrap (#try.Failure error)))))) + ) + ) + +(def: (default_on_mail mail state self) + (All [s] (-> (Mail s) s (Actor s) (Promise (Try s)))) + (mail state self)) + +(def: #export default + (All [s] (Behavior s s)) + {#on_init function.identity + #on_mail ..default_on_mail}) + +(def: #export (poison! actor) + {#.doc (doc "Kills the actor by sending mail that will kill it upon processing," + "but allows the actor to handle previous mail.")} + (All [s] (-> (Actor s) (IO (Try Any)))) + (..mail! (function (_ state self) + (promise.resolved (exception.throw ..poisoned []))) + actor)) + +(def: actor_decl^ + (Parser [Text (List Text)]) + (<>.either (<code>.form (<>.and <code>.local_identifier (<>.some <code>.local_identifier))) + (<>.and <code>.local_identifier (\ <>.monad wrap (list))))) + +(type: On_MailC + [[Text Text Text] Code]) + +(type: BehaviorC + [(Maybe On_MailC) (List Code)]) + +(def: argument + (Parser Text) + <code>.local_identifier) + +(def: behavior^ + (Parser BehaviorC) + (let [on_mail_args ($_ <>.and ..argument ..argument ..argument)] + ($_ <>.and + (<>.maybe (<code>.form (<>.and (<code>.form (<>.after (<code>.this! (' on_mail)) on_mail_args)) + <code>.any))) + (<>.some <code>.any)))) + +(def: (on_mail g!_ ?on_mail) + (-> Code (Maybe On_MailC) Code) + (case ?on_mail + #.None + (` (~! ..default_on_mail)) + + (#.Some [[mailN stateN selfN] bodyC]) + (` (function ((~ g!_) + (~ (code.local_identifier mailN)) + (~ (code.local_identifier stateN)) + (~ (code.local_identifier selfN))) + (~ bodyC))))) + +(with_expansions [<examples> (as_is (actor: #export (Stack a) + (List a) + + ((on_mail mail state self) + (do (try.with promise.monad) + [#let [_ (log! "BEFORE")] + output (mail state self) + #let [_ (log! "AFTER")]] + (wrap output))) + + (message: #export (push {value a} state self (List a)) + (let [state' (#.Cons value state)] + (promise.resolved (#try.Success [state' state']))))) + + (actor: #export Counter + Nat + + (message: #export (count! {increment Nat} state self Any) + (let [state' (n.+ increment state)] + (promise.resolved (#try.Success [state' state'])))) + + (message: #export (read! state self Nat) + (promise.resolved (#try.Success [state state])))))] + (syntax: #export (actor: + {export |export|.parser} + {[name vars] actor_decl^} + {annotations (<>.default |annotations|.empty |annotations|.parser)} + state_type + {[?on_mail messages] behavior^}) + {#.doc (doc "Defines an actor, with its behavior and internal state." + "Messages for the actor must be defined after the on_mail handler." + <examples>)} + (with_gensyms [g!_] + (do meta.monad + [g!type (macro.gensym (format name "_abstract_type")) + #let [g!actor (code.local_identifier name) + g!vars (list\map code.local_identifier vars)]] + (wrap (list (` ((~! abstract:) (~+ (|export|.format export)) ((~ g!type) (~+ g!vars)) + (~ state_type) + + (def: (~+ (|export|.format export)) (~ g!actor) + (All [(~+ g!vars)] + (..Behavior (~ state_type) ((~ g!type) (~+ g!vars)))) + {#..on_init (|>> ((~! abstract.:abstraction) (~ g!type))) + #..on_mail (~ (..on_mail g!_ ?on_mail))}) + + (~+ messages)))))))) + + (syntax: #export (actor {[state_type init] (<code>.record (<>.and <code>.any <code>.any))} + {[?on_mail messages] behavior^}) + (with_gensyms [g!_] + (wrap (list (` (: ((~! io.IO) (..Actor (~ state_type))) + (..spawn! (: (..Behavior (~ state_type) (~ state_type)) + {#..on_init (|>>) + #..on_mail (~ (..on_mail g!_ ?on_mail))}) + (: (~ state_type) + (~ init))))))))) + + (type: Signature + {#vars (List Text) + #name Text + #inputs (List |input|.Input) + #state Text + #self Text + #output Code}) + + (def: signature^ + (Parser Signature) + (<code>.form ($_ <>.and + (<>.default (list) (<code>.tuple (<>.some <code>.local_identifier))) + <code>.local_identifier + (<>.some |input|.parser) + <code>.local_identifier + <code>.local_identifier + <code>.any))) + + (def: reference^ + (Parser [Name (List Text)]) + (<>.either (<code>.form (<>.and <code>.identifier (<>.some <code>.local_identifier))) + (<>.and <code>.identifier (\ <>.monad wrap (list))))) + + (syntax: #export (message: + {export |export|.parser} + {signature signature^} + {annotations (<>.default |annotations|.empty |annotations|.parser)} + body) + {#.doc (doc "A message can access the actor's state through the state parameter." + "A message can also access the actor itself through the self parameter." + "A message's output must be a promise containing a 2-tuple with the updated state and a return value." + "A message may succeed or fail (in case of failure, the actor dies)." + + <examples>)} + (with_gensyms [g!_ g!return] + (do meta.monad + [actor_scope abstract.current + #let [g!type (code.local_identifier (get@ #abstract.name actor_scope)) + g!message (code.local_identifier (get@ #name signature)) + g!actor_vars (get@ #abstract.type_vars actor_scope) + g!all_vars (|> signature (get@ #vars) (list\map code.local_identifier) (list\compose g!actor_vars)) + g!inputsC (|> signature (get@ #inputs) (list\map product.left)) + g!inputsT (|> signature (get@ #inputs) (list\map product.right)) + g!state (|> signature (get@ #state) code.local_identifier) + g!self (|> signature (get@ #self) code.local_identifier)]] + (wrap (list (` (def: (~+ (|export|.format export)) ((~ g!message) (~+ g!inputsC)) + (~ (|annotations|.format annotations)) + (All [(~+ g!all_vars)] + (-> (~+ g!inputsT) + (..Message (~ (get@ #abstract.abstraction actor_scope)) + (~ (get@ #output signature))))) + (function ((~ g!_) (~ g!state) (~ g!self)) + (let [(~ g!state) (:as (~ (get@ #abstract.representation actor_scope)) + (~ g!state))] + (|> (~ body) + (: ((~! promise.Promise) ((~! try.Try) [(~ (get@ #abstract.representation actor_scope)) + (~ (get@ #output signature))]))) + (:as ((~! promise.Promise) ((~! try.Try) [(~ (get@ #abstract.abstraction actor_scope)) + (~ (get@ #output signature))])))))))) + )))))) + +(type: #export Stop + (IO Any)) + +(def: continue! true) +(def: stop! false) + +(def: #export (observe action channel actor) + (All [e s] (-> (-> e Stop (Mail s)) (Channel e) (Actor s) (IO Any))) + (let [signal (: (Atom Bit) + (atom.atom ..continue!)) + stop (: Stop + (atom.write ..stop! signal))] + (frp.subscribe (function (_ event) + (do {! io.monad} + [continue? (atom.read signal)] + (if continue? + (do ! + [outcome (..mail! (action event stop) actor)] + (wrap (try.to_maybe outcome))) + (wrap #.None)))) + channel))) diff --git a/stdlib/source/library/lux/control/concurrency/atom.lux b/stdlib/source/library/lux/control/concurrency/atom.lux new file mode 100644 index 000000000..057bfd5b2 --- /dev/null +++ b/stdlib/source/library/lux/control/concurrency/atom.lux @@ -0,0 +1,103 @@ +(.module: + [library + [lux #* + ["." ffi] + ["@" target] + [abstract + [monad (#+ do)]] + [control + ["." function] + ["." io (#- run) ("#\." functor)]] + [data + ["." product] + [collection + ["." array]]] + [type + abstract]]]) + +(with_expansions [<jvm> (as_is (ffi.import: (java/util/concurrent/atomic/AtomicReference a) + ["#::." + (new [a]) + (get [] a) + (compareAndSet [a a] boolean)]))] + (for {@.old <jvm> + @.jvm <jvm>} + (as_is))) + +(with_expansions [<new> (for {@.js "js array new" + @.python "python array new" + @.lua "lua array new" + @.ruby "ruby array new" + @.php "php array new" + @.scheme "scheme array new"} + (as_is)) + <write> (for {@.js "js array write" + @.python "python array write" + @.lua "lua array write" + @.ruby "ruby array write" + @.php "php array write" + @.scheme "scheme array write"} + (as_is)) + + <read> (for {@.js "js array read" + @.python "python array read" + @.lua "lua array read" + @.ruby "ruby array read" + @.php "php array read" + @.scheme "scheme array read"} + (as_is))] + (abstract: #export (Atom a) + (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference a)] + (for {@.old <jvm> + @.jvm <jvm>} + (array.Array a))) + + {#.doc "Atomic references that are safe to mutate concurrently."} + + (def: #export (atom value) + (All [a] (-> a (Atom a))) + (:abstraction (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::new value)] + (for {@.old <jvm> + @.jvm <jvm>} + (<write> 0 value (<new> 1)))))) + + (def: #export (read atom) + (All [a] (-> (Atom a) (IO a))) + (io (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::get (:representation atom))] + (for {@.old <jvm> + @.jvm <jvm>} + (<read> 0 (:representation atom)))))) + + (def: #export (compare_and_swap current new atom) + {#.doc (doc "Only mutates an atom if you can present its current value." + "That guarantees that atom was not updated since you last read from it.")} + (All [a] (-> a a (Atom a) (IO Bit))) + (io (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::compareAndSet current new (:representation atom))] + (for {@.old <jvm> + @.jvm <jvm>} + (let [old (<read> 0 (:representation atom))] + (if (is? old current) + (exec (<write> 0 new (:representation atom)) + true) + false)))))) + )) + +(def: #export (update f atom) + {#.doc (doc "Updates an atom by applying a function to its current value." + "If it fails to update it (because some other process wrote to it first), it will retry until it succeeds." + "The retries will be done with the new values of the atom, as they show up.")} + (All [a] (-> (-> a a) (Atom a) (IO [a a]))) + (loop [_ []] + (do io.monad + [old (read atom) + #let [new (f old)] + swapped? (..compare_and_swap old new atom)] + (if swapped? + (wrap [old new]) + (recur []))))) + +(def: #export (write value atom) + (All [a] (-> a (Atom a) (IO a))) + (|> atom + (..update (function.constant value)) + (io\map product.left))) diff --git a/stdlib/source/library/lux/control/concurrency/frp.lux b/stdlib/source/library/lux/control/concurrency/frp.lux new file mode 100644 index 000000000..416b8c7c4 --- /dev/null +++ b/stdlib/source/library/lux/control/concurrency/frp.lux @@ -0,0 +1,296 @@ +(.module: + [library + [lux #* + [abstract + [predicate (#+ Predicate)] + [equivalence (#+ Equivalence)] + [functor (#+ Functor)] + [apply (#+ Apply)] + ["." monad (#+ Monad do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["." io (#+ IO io)]] + [data + ["." maybe ("#\." functor)]] + [type (#+ :share) + abstract]]] + [// + ["." atom (#+ Atom)] + ["." promise (#+ Promise) ("#\." functor)]]) + +(type: #export (Channel a) + {#.doc "An asynchronous channel to distribute values."} + (Promise (Maybe [a (Channel a)]))) + +(exception: #export channel_is_already_closed) + +(interface: #export (Sink a) + (: (IO (Try Any)) + close) + (: (-> a (IO (Try Any))) + feed)) + +(def: (sink resolve) + (All [a] + (-> (promise.Resolver (Maybe [a (Channel a)])) + (Sink a))) + (let [sink (atom.atom resolve)] + (implementation + (def: close + (loop [_ []] + (do {! io.monad} + [current (atom.read sink) + stopped? (current #.None)] + (if stopped? + ## I closed the sink. + (wrap (exception.return [])) + ## Someone else interacted with the sink. + (do ! + [latter (atom.read sink)] + (if (is? current latter) + ## Someone else closed the sink. + (wrap (exception.throw ..channel_is_already_closed [])) + ## Someone else fed the sink while I was closing it. + (recur []))))))) + + (def: (feed value) + (loop [_ []] + (do {! io.monad} + [current (atom.read sink) + #let [[next resolve_next] (:share [a] + (promise.Resolver (Maybe [a (Channel a)])) + current + + [(Promise (Maybe [a (Channel a)])) + (promise.Resolver (Maybe [a (Channel a)]))] + (promise.promise []))] + fed? (current (#.Some [value next]))] + (if fed? + ## I fed the sink. + (do ! + [_ (atom.compare_and_swap current resolve_next sink)] + (wrap (exception.return []))) + ## Someone else interacted with the sink. + (do ! + [latter (atom.read sink)] + (if (is? current latter) + ## Someone else closed the sink while I was feeding it. + (wrap (exception.throw ..channel_is_already_closed [])) + ## Someone else fed the sink. + (recur [])))))))))) + +(def: #export (channel _) + (All [a] (-> Any [(Channel a) (Sink a)])) + (let [[promise resolve] (promise.promise [])] + [promise (..sink resolve)])) + +(implementation: #export functor + (Functor Channel) + + (def: (map f) + (promise\map + (maybe\map + (function (_ [head tail]) + [(f head) (map f tail)]))))) + +(implementation: #export apply + (Apply Channel) + + (def: &functor ..functor) + + (def: (apply ff fa) + (do promise.monad + [cons_f ff + cons_a fa] + (case [cons_f cons_a] + [(#.Some [head_f tail_f]) (#.Some [head_a tail_a])] + (wrap (#.Some [(head_f head_a) (apply tail_f tail_a)])) + + _ + (wrap #.None))))) + +(def: empty + Channel + (promise.resolved #.None)) + +(implementation: #export monad + (Monad Channel) + + (def: &functor ..functor) + + (def: (wrap a) + (promise.resolved (#.Some [a ..empty]))) + + (def: (join mma) + (let [[output sink] (channel [])] + (exec (: (Promise Any) + (loop [mma mma] + (do {! promise.monad} + [?mma mma] + (case ?mma + (#.Some [ma mma']) + (do ! + [_ (loop [ma ma] + (do ! + [?ma ma] + (case ?ma + (#.Some [a ma']) + (exec (io.run (\ sink feed a)) + (recur ma')) + + #.None + (wrap []))))] + (recur mma')) + + #.None + (wrap (: Any (io.run (\ sink close)))))))) + output)))) + +(type: #export (Subscriber a) + (-> a (IO (Maybe Any)))) + +(def: #export (subscribe subscriber channel) + (All [a] (-> (Subscriber a) (Channel a) (IO Any))) + (io (exec (: (Promise Any) + (loop [channel channel] + (do promise.monad + [cons channel] + (case cons + (#.Some [head tail]) + (case (io.run (subscriber head)) + (#.Some _) + (recur tail) + + #.None + (wrap [])) + + #.None + (wrap []))))) + []))) + +(def: #export (filter pass? channel) + (All [a] (-> (Predicate a) (Channel a) (Channel a))) + (do promise.monad + [cons channel] + (case cons + (#.Some [head tail]) + (let [tail' (filter pass? tail)] + (if (pass? head) + (wrap (#.Some [head tail'])) + tail')) + + #.None + (wrap #.None)))) + +(def: #export (from_promise promise) + (All [a] (-> (Promise a) (Channel a))) + (promise\map (function (_ value) + (#.Some [value ..empty])) + promise)) + +(def: #export (fold f init channel) + {#.doc "Asynchronous fold over channels."} + (All [a b] + (-> (-> b a (Promise a)) a (Channel b) + (Promise a))) + (do {! promise.monad} + [cons channel] + (case cons + #.None + (wrap init) + + (#.Some [head tail]) + (do ! + [init' (f head init)] + (fold f init' tail))))) + +(def: #export (folds f init channel) + {#.doc "A channel of folds."} + (All [a b] + (-> (-> b a (Promise a)) a (Channel b) + (Channel a))) + (do {! promise.monad} + [cons channel] + (case cons + #.None + (wrap (#.Some [init (wrap #.None)])) + + (#.Some [head tail]) + (do ! + [init' (f head init)] + (wrap (#.Some [init (folds f init' tail)])))))) + +(def: #export (poll milli_seconds action) + (All [a] + (-> Nat (IO a) [(Channel a) (Sink a)])) + (let [[output sink] (channel [])] + (exec (io.run (loop [_ []] + (do io.monad + [value action + _ (\ sink feed value)] + (promise.await recur (promise.wait milli_seconds))))) + [output sink]))) + +(def: #export (periodic milli_seconds) + (-> Nat [(Channel Any) (Sink Any)]) + (..poll milli_seconds (io []))) + +(def: #export (iterate f init) + (All [s o] (-> (-> s (Promise (Maybe [s o]))) s (Channel o))) + (do promise.monad + [?next (f init)] + (case ?next + (#.Some [state output]) + (wrap (#.Some [output (iterate f state)])) + + #.None + (wrap #.None)))) + +(def: (distinct' equivalence previous channel) + (All [a] (-> (Equivalence a) a (Channel a) (Channel a))) + (do promise.monad + [cons channel] + (case cons + (#.Some [head tail]) + (if (\ equivalence = previous head) + (distinct' equivalence previous tail) + (wrap (#.Some [head (distinct' equivalence head tail)]))) + + #.None + (wrap #.None)))) + +(def: #export (distinct equivalence channel) + (All [a] (-> (Equivalence a) (Channel a) (Channel a))) + (do promise.monad + [cons channel] + (case cons + (#.Some [head tail]) + (wrap (#.Some [head (distinct' equivalence head tail)])) + + #.None + (wrap #.None)))) + +(def: #export (consume channel) + {#.doc "Reads the entirety of a channel's content and returns it as a list."} + (All [a] (-> (Channel a) (Promise (List a)))) + (do {! promise.monad} + [cons channel] + (case cons + (#.Some [head tail]) + (\ ! map (|>> (#.Cons head)) + (consume tail)) + + #.None + (wrap #.Nil)))) + +(def: #export (sequential milli_seconds values) + (All [a] (-> Nat (List a) (Channel a))) + (case values + #.Nil + ..empty + + (#.Cons head tail) + (promise.resolved (#.Some [head (do promise.monad + [_ (promise.wait milli_seconds)] + (sequential milli_seconds tail))])))) diff --git a/stdlib/source/library/lux/control/concurrency/promise.lux b/stdlib/source/library/lux/control/concurrency/promise.lux new file mode 100644 index 000000000..ad94bbff8 --- /dev/null +++ b/stdlib/source/library/lux/control/concurrency/promise.lux @@ -0,0 +1,200 @@ +(.module: + [library + [lux (#- and or) + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + ["." monad (#+ Monad do)]] + [control + [pipe (#+ case>)] + ["." function] + ["." io (#+ IO io)]] + [data + ["." product]] + [type (#+ :share) + abstract]]] + [// + ["." thread] + ["." atom (#+ Atom atom)]]) + +(abstract: #export (Promise a) + (Atom [(Maybe a) (List (-> a (IO Any)))]) + + {#.doc "Represents values produced by asynchronous computations (unlike IO, which is synchronous)."} + + (type: #export (Resolver a) + (-> a (IO Bit))) + + (def: (resolver promise) + {#.doc "Sets an promise's value if it has not been done yet."} + (All [a] (-> (Promise a) (Resolver a))) + (function (resolve value) + (let [promise (:representation promise)] + (do {! io.monad} + [(^@ old [_value _observers]) (atom.read promise)] + (case _value + (#.Some _) + (wrap #0) + + #.None + (do ! + [#let [new [(#.Some value) #.None]] + succeeded? (atom.compare_and_swap old new promise)] + (if succeeded? + (do ! + [_ (monad.map ! (function (_ f) (f value)) + _observers)] + (wrap #1)) + (resolve value)))))))) + + (def: #export (resolved value) + (All [a] (-> a (Promise a))) + (:abstraction (atom [(#.Some value) (list)]))) + + (def: #export (promise _) + (All [a] (-> Any [(Promise a) (Resolver a)])) + (let [promise (:abstraction (atom [#.None (list)]))] + [promise (..resolver promise)])) + + (def: #export poll + {#.doc "Polls a promise's value."} + (All [a] (-> (Promise a) (IO (Maybe a)))) + (|>> :representation + atom.read + (\ io.functor map product.left))) + + (def: #export (await f promise) + (All [a] (-> (-> a (IO Any)) (Promise a) (IO Any))) + (do {! io.monad} + [#let [promise (:representation promise)] + (^@ old [_value _observers]) (atom.read promise)] + (case _value + (#.Some value) + (f value) + + #.None + (let [new [_value (#.Cons f _observers)]] + (do ! + [swapped? (atom.compare_and_swap old new promise)] + (if swapped? + (wrap []) + (await f (:abstraction promise)))))))) + ) + +(def: #export resolved? + {#.doc "Checks whether a promise's value has already been resolved."} + (All [a] (-> (Promise a) (IO Bit))) + (|>> ..poll + (\ io.functor map + (|>> (case> #.None + #0 + + (#.Some _) + #1))))) + +(implementation: #export functor + (Functor Promise) + + (def: (map f fa) + (let [[fb resolve] (..promise [])] + (exec (io.run (..await (|>> f resolve) fa)) + fb)))) + +(implementation: #export apply + (Apply Promise) + + (def: &functor ..functor) + + (def: (apply ff fa) + (let [[fb resolve] (..promise [])] + (exec (io.run (..await (function (_ f) + (..await (|>> f resolve) fa)) + ff)) + fb)))) + +(implementation: #export monad + (Monad Promise) + + (def: &functor ..functor) + + (def: wrap ..resolved) + + (def: (join mma) + (let [[ma resolve] (promise [])] + (exec (io.run (..await (..await resolve) mma)) + ma)))) + +(def: #export (and left right) + {#.doc "Sequencing combinator."} + (All [a b] (-> (Promise a) (Promise b) (Promise [a b]))) + (let [[read! write!] (:share [a b] + [(Promise a) (Promise b)] + [left right] + + [(Promise [a b]) + (Resolver [a b])] + (..promise [])) + _ (io.run (..await (function (_ left) + (..await (function (_ right) + (write! [left right])) + right)) + left))] + read!)) + +(def: #export (or left right) + {#.doc "Heterogeneous alternative combinator."} + (All [a b] (-> (Promise a) (Promise b) (Promise (| a b)))) + (let [[a|b resolve] (..promise [])] + (with_expansions + [<sides> (template [<promise> <tag>] + [(io.run (await (|>> <tag> resolve) <promise>))] + + [left #.Left] + [right #.Right] + )] + (exec <sides> + a|b)))) + +(def: #export (either left right) + {#.doc "Homogeneous alternative combinator."} + (All [a] (-> (Promise a) (Promise a) (Promise a))) + (let [[left||right resolve] (..promise [])] + (`` (exec (~~ (template [<promise>] + [(io.run (await resolve <promise>))] + + [left] + [right])) + left||right)))) + +(def: #export (schedule millis_delay computation) + {#.doc (doc "Runs an I/O computation on its own thread (after a specified delay)." + "Returns a Promise that will eventually host its result.")} + (All [a] (-> Nat (IO a) (Promise a))) + (let [[!out resolve] (..promise [])] + (exec (|> (do io.monad + [value computation] + (resolve value)) + (thread.schedule millis_delay) + io.run) + !out))) + +(def: #export future + {#.doc (doc "Runs an I/O computation on its own thread." + "Returns a Promise that will eventually host its result.")} + (All [a] (-> (IO a) (Promise a))) + (..schedule 0)) + +(def: #export (delay time_millis value) + {#.doc "Delivers a value after a certain period has passed."} + (All [a] (-> Nat a (Promise a))) + (..schedule time_millis (io value))) + +(def: #export (wait time_millis) + {#.doc "Returns a promise that will be resolved after the specified amount of milliseconds."} + (-> Nat (Promise Any)) + (..delay time_millis [])) + +(def: #export (time_out time_millis promise) + {#.doc "Wait for a promise to be resolved within the specified amount of milliseconds."} + (All [a] (-> Nat (Promise a) (Promise (Maybe a)))) + (..or (wait time_millis) promise)) diff --git a/stdlib/source/library/lux/control/concurrency/semaphore.lux b/stdlib/source/library/lux/control/concurrency/semaphore.lux new file mode 100644 index 000000000..597e96306 --- /dev/null +++ b/stdlib/source/library/lux/control/concurrency/semaphore.lux @@ -0,0 +1,174 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + [pipe (#+ if>)] + ["." io (#+ IO)] + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + [text + ["%" format (#+ format)]] + [collection + ["." queue (#+ Queue)]]] + [math + [number + ["n" nat] + ["i" int]]] + [type + abstract + ["." refinement]]]] + [// + ["." atom (#+ Atom)] + ["." promise (#+ Promise Resolver)]]) + +(type: State + {#max_positions Nat + #open_positions Int + #waiting_list (Queue (Resolver Any))}) + +(abstract: #export Semaphore + (Atom State) + + {#.doc "A tool for controlling access to resources by multiple concurrent processes."} + + (def: most_positions_possible + (.nat (\ i.interval top))) + + (def: #export (semaphore initial_open_positions) + (-> Nat Semaphore) + (let [max_positions (n.min initial_open_positions + ..most_positions_possible)] + (:abstraction (atom.atom {#max_positions max_positions + #open_positions (.int max_positions) + #waiting_list queue.empty})))) + + (def: #export (wait semaphore) + (Ex [k] (-> Semaphore (Promise Any))) + (let [semaphore (:representation semaphore) + [signal sink] (: [(Promise Any) (Resolver Any)] + (promise.promise []))] + (exec (io.run + (with_expansions [<had_open_position?> (as_is (get@ #open_positions) (i.> -1))] + (do io.monad + [[_ state'] (atom.update (|>> (update@ #open_positions dec) + (if> [<had_open_position?>] + [] + [(update@ #waiting_list (queue.push sink))])) + semaphore)] + (with_expansions [<go_ahead> (sink []) + <get_in_line> (wrap false)] + (if (|> state' <had_open_position?>) + <go_ahead> + <get_in_line>))))) + signal))) + + (exception: #export (semaphore_is_maxed_out {max_positions Nat}) + (exception.report + ["Max Positions" (%.nat max_positions)])) + + (def: #export (signal semaphore) + (Ex [k] (-> Semaphore (Promise (Try Int)))) + (let [semaphore (:representation semaphore)] + (promise.future + (do {! io.monad} + [[pre post] (atom.update (function (_ state) + (if (i.= (.int (get@ #max_positions state)) + (get@ #open_positions state)) + state + (|> state + (update@ #open_positions inc) + (update@ #waiting_list queue.pop)))) + semaphore)] + (if (is? pre post) + (wrap (exception.throw ..semaphore_is_maxed_out [(get@ #max_positions pre)])) + (do ! + [_ (case (queue.peek (get@ #waiting_list pre)) + #.None + (wrap true) + + (#.Some sink) + (sink []))] + (wrap (#try.Success (get@ #open_positions post))))))))) + ) + +(abstract: #export Mutex + Semaphore + + {#.doc "A mutual-exclusion lock that can only be acquired by one process at a time."} + + (def: #export (mutex _) + (-> Any Mutex) + (:abstraction (semaphore 1))) + + (def: acquire + (-> Mutex (Promise Any)) + (|>> :representation ..wait)) + + (def: release + (-> Mutex (Promise Any)) + (|>> :representation ..signal)) + + (def: #export (synchronize mutex procedure) + (All [a] (-> Mutex (IO (Promise a)) (Promise a))) + (do promise.monad + [_ (..acquire mutex) + output (io.run procedure) + _ (..release mutex)] + (wrap output))) + ) + +(def: #export limit + (refinement.refinement (n.> 0))) + +(type: #export Limit + (:~ (refinement.type limit))) + +(abstract: #export Barrier + {#limit Limit + #count (Atom Nat) + #start_turnstile Semaphore + #end_turnstile Semaphore} + + {#.doc "A barrier that blocks all processes from proceeding until a given number of processes are parked at the barrier."} + + (def: #export (barrier limit) + (-> Limit Barrier) + (:abstraction {#limit limit + #count (atom.atom 0) + #start_turnstile (..semaphore 0) + #end_turnstile (..semaphore 0)})) + + (def: (un_block times turnstile) + (-> Nat Semaphore (Promise Any)) + (loop [step 0] + (if (n.< times step) + (do promise.monad + [outcome (..signal turnstile)] + (recur (inc step))) + (\ promise.monad wrap [])))) + + (template [<phase> <update> <goal> <turnstile>] + [(def: (<phase> (^:representation barrier)) + (-> Barrier (Promise Any)) + (do promise.monad + [#let [limit (refinement.un_refine (get@ #limit barrier)) + goal <goal> + [_ count] (io.run (atom.update <update> (get@ #count barrier))) + reached? (n.= goal count)]] + (if reached? + (..un_block (dec limit) (get@ <turnstile> barrier)) + (..wait (get@ <turnstile> barrier)))))] + + [start inc limit #start_turnstile] + [end dec 0 #end_turnstile] + ) + + (def: #export (block barrier) + (-> Barrier (Promise Any)) + (do promise.monad + [_ (..start barrier)] + (..end barrier))) + ) diff --git a/stdlib/source/library/lux/control/concurrency/stm.lux b/stdlib/source/library/lux/control/concurrency/stm.lux new file mode 100644 index 000000000..081d2f3d9 --- /dev/null +++ b/stdlib/source/library/lux/control/concurrency/stm.lux @@ -0,0 +1,274 @@ +(.module: + [library + [lux #* + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + ["." monad (#+ Monad do)]] + [control + ["." io (#+ IO io)] + ["." try]] + [data + ["." product] + ["." maybe] + [collection + ["." list]]] + [type + abstract]]] + [// + ["." atom (#+ Atom atom)] + ["." promise (#+ Promise Resolver)] + ["." frp (#+ Channel Sink)]]) + +(type: (Observer a) + (-> a (IO Any))) + +(abstract: #export (Var a) + (Atom [a (List (Sink a))]) + + {#.doc "A mutable cell containing a value, and observers that will be alerted of any change to it."} + + (def: #export (var value) + {#.doc "Creates a new STM var, with a default value."} + (All [a] (-> a (Var a))) + (:abstraction (atom.atom [value (list)]))) + + (def: read! + (All [a] (-> (Var a) a)) + (|>> :representation atom.read io.run product.left)) + + (def: (un_follow sink var) + (All [a] (-> (Sink a) (Var a) (IO Any))) + (do io.monad + [_ (atom.update (function (_ [value observers]) + [value (list.filter (|>> (is? sink) not) observers)]) + (:representation var))] + (wrap []))) + + (def: (write! new_value var) + (All [a] (-> a (Var a) (IO Any))) + (do {! io.monad} + [#let [var' (:representation var)] + (^@ old [old_value observers]) (atom.read var') + succeeded? (atom.compare_and_swap old [new_value observers] var')] + (if succeeded? + (do ! + [_ (monad.map ! (function (_ sink) + (do ! + [result (\ sink feed new_value)] + (case result + (#try.Success _) + (wrap []) + + (#try.Failure _) + (un_follow sink var)))) + observers)] + (wrap [])) + (write! new_value var)))) + + (def: #export (follow target) + {#.doc "Creates a channel that will receive all changes to the value of the given var."} + (All [a] (-> (Var a) (IO [(Channel a) (Sink a)]))) + (do io.monad + [#let [[channel sink] (frp.channel [])] + _ (atom.update (function (_ [value observers]) + [value (#.Cons sink observers)]) + (:representation target))] + (wrap [channel sink]))) + ) + +(type: (Tx_Frame a) + {#var (Var a) + #original a + #current a}) + +(type: Tx + (List (Ex [a] (Tx_Frame a)))) + +(type: #export (STM a) + {#.doc "A computation which updates a transaction and produces a value."} + (-> Tx [Tx a])) + +(def: (find_var_value var tx) + (All [a] (-> (Var a) Tx (Maybe a))) + (|> tx + (list.find (function (_ [_var _original _current]) + (is? (:as (Var Any) var) + (:as (Var Any) _var)))) + (\ maybe.monad map (function (_ [_var _original _current]) + _current)) + (:assume) + )) + +(def: #export (read var) + (All [a] (-> (Var a) (STM a))) + (function (_ tx) + (case (find_var_value var tx) + (#.Some value) + [tx value] + + #.None + (let [value (..read! var)] + [(#.Cons [var value value] tx) + value])))) + +(def: (update_tx_value var value tx) + (All [a] (-> (Var a) a Tx Tx)) + (case tx + #.Nil + #.Nil + + (#.Cons [_var _original _current] tx') + (if (is? (:as (Var Any) var) + (:as (Var Any) _var)) + (#.Cons {#var (:as (Var Any) _var) + #original (:as Any _original) + #current (:as Any value)} + tx') + (#.Cons {#var _var + #original _original + #current _current} + (update_tx_value var value tx'))))) + +(def: #export (write value var) + {#.doc "Writes value to var."} + (All [a] (-> a (Var a) (STM Any))) + (function (_ tx) + (case (find_var_value var tx) + (#.Some _) + [(update_tx_value var value tx) + []] + + #.None + [(#.Cons [var (..read! var) value] tx) + []]))) + +(implementation: #export functor + (Functor STM) + + (def: (map f fa) + (function (_ tx) + (let [[tx' a] (fa tx)] + [tx' (f a)])))) + +(implementation: #export apply + (Apply STM) + + (def: &functor ..functor) + + (def: (apply ff fa) + (function (_ tx) + (let [[tx' f] (ff tx) + [tx'' a] (fa tx')] + [tx'' (f a)])))) + +(implementation: #export monad + (Monad STM) + + (def: &functor ..functor) + + (def: (wrap a) + (function (_ tx) + [tx a])) + + (def: (join mma) + (function (_ tx) + (let [[tx' ma] (mma tx)] + (ma tx'))))) + +(def: #export (update f var) + {#.doc "Will update a Var's value, and return a tuple with the old and the new values."} + (All [a] (-> (-> a a) (Var a) (STM [a a]))) + (do ..monad + [a (..read var) + #let [a' (f a)] + _ (..write a' var)] + (wrap [a a']))) + +(def: (can_commit? tx) + (-> Tx Bit) + (list.every? (function (_ [_var _original _current]) + (is? _original (..read! _var))) + tx)) + +(def: (commit_var! [_var _original _current]) + (-> (Ex [a] (Tx_Frame a)) (IO Any)) + (if (is? _original _current) + (io []) + (..write! _current _var))) + +(def: fresh_tx Tx (list)) + +(type: (Commit a) + [(STM a) + (Promise a) + (Resolver a)]) + +(def: pending_commits + (Atom (Rec Commits + [(Promise [(Ex [a] (Commit a)) Commits]) + (Resolver [(Ex [a] (Commit a)) Commits])])) + (atom (promise.promise []))) + +(def: commit_processor_flag + (Atom Bit) + (atom #0)) + +(def: (issue_commit commit) + (All [a] (-> (Commit a) (IO Any))) + (let [entry [commit (promise.promise [])]] + (do {! io.monad} + [|commits|&resolve (atom.read pending_commits)] + (loop [[|commits| resolve] |commits|&resolve] + (do ! + [|commits| (promise.poll |commits|)] + (case |commits| + #.None + (do io.monad + [resolved? (resolve entry)] + (if resolved? + (atom.write (product.right entry) pending_commits) + (recur |commits|&resolve))) + + (#.Some [head tail]) + (recur tail))))))) + +(def: (process_commit commit) + (All [a] (-> (Commit a) (IO Any))) + (let [[stm_proc output resolve] commit + [finished_tx value] (stm_proc fresh_tx)] + (if (can_commit? finished_tx) + (do {! io.monad} + [_ (monad.map ! commit_var! finished_tx)] + (resolve value)) + (issue_commit commit)))) + +(def: init_processor! + (IO Any) + (do {! io.monad} + [flag (atom.read commit_processor_flag)] + (if flag + (wrap []) + (do ! + [was_first? (atom.compare_and_swap flag #1 commit_processor_flag)] + (if was_first? + (do ! + [[promise resolve] (atom.read pending_commits)] + (promise.await (function (recur [head [tail _resolve]]) + (do ! + [_ (process_commit head)] + (promise.await recur tail))) + promise)) + (wrap []))) + ))) + +(def: #export (commit stm_proc) + {#.doc (doc "Commits a transaction and returns its result (asynchronously)." + "Note that a transaction may be re-run an indeterminate number of times if other transactions involving the same variables successfully commit first." + "For this reason, it's important to note that transactions must be free from side-effects, such as I/O.")} + (All [a] (-> (STM a) (Promise a))) + (let [[output resolver] (promise.promise [])] + (exec (io.run (do io.monad + [_ init_processor!] + (issue_commit [stm_proc output resolver]))) + output))) diff --git a/stdlib/source/library/lux/control/concurrency/thread.lux b/stdlib/source/library/lux/control/concurrency/thread.lux new file mode 100644 index 000000000..9c9bf6549 --- /dev/null +++ b/stdlib/source/library/lux/control/concurrency/thread.lux @@ -0,0 +1,170 @@ +(.module: + [library + [lux #* + ["@" target] + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["." exception (#+ exception:)] + ["." io (#+ IO io)]] + [data + ["." text] + [collection + ["." list]]] + [math + [number + ["n" nat] + ["f" frac]]] + [time + ["." instant]]]] + [// + ["." atom (#+ Atom)]]) + +(with_expansions [<jvm> (as_is (ffi.import: java/lang/Object) + + (ffi.import: java/lang/Runtime + ["#::." + (#static getRuntime [] java/lang/Runtime) + (availableProcessors [] int)]) + + (ffi.import: java/lang/Runnable) + + (ffi.import: java/util/concurrent/TimeUnit + ["#::." + (#enum MILLISECONDS)]) + + (ffi.import: java/util/concurrent/Executor + ["#::." + (execute [java/lang/Runnable] #io void)]) + + (ffi.import: (java/util/concurrent/ScheduledFuture a)) + + (ffi.import: java/util/concurrent/ScheduledThreadPoolExecutor + ["#::." + (new [int]) + (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object))]))] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>) + + @.js + (as_is (ffi.import: (setTimeout [ffi.Function ffi.Number] #io Any))) + + @.python + (ffi.import: threading/Timer + ["#::." + (new [ffi.Float ffi.Function]) + (start [] #io #? Any)])} + + ## Default + (type: Thread + {#creation Nat + #delay Nat + #action (IO Any)}) + )) + +(def: #export parallelism + Nat + (with_expansions [<jvm> (|> (java/lang/Runtime::getRuntime) + (java/lang/Runtime::availableProcessors) + .nat)] + (for {@.old <jvm> + @.jvm <jvm>} + ## Default + 1))) + +(with_expansions [<jvm> (as_is (def: runner + java/util/concurrent/ScheduledThreadPoolExecutor + (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))))] + (for {@.old <jvm> + @.jvm <jvm> + @.js (as_is) + @.python (as_is)} + + ## Default + (def: runner + (Atom (List Thread)) + (atom.atom (list))))) + +(def: (execute! action) + (-> (IO Any) Any) + (case (try (io.run action)) + (#try.Failure error) + (exec + ("lux io log" ($_ "lux text concat" + "ERROR DURING THREAD EXECUTION:" text.new_line + error)) + []) + + (#try.Success _) + [])) + +(def: #export (schedule milli_seconds action) + (-> Nat (IO Any) (IO Any)) + (with_expansions [<jvm> (as_is (let [runnable (ffi.object [] [java/lang/Runnable] + [] + (java/lang/Runnable [] (run self) void + (..execute! action)))] + (case milli_seconds + 0 (java/util/concurrent/Executor::execute runnable runner) + _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli_seconds) java/util/concurrent/TimeUnit::MILLISECONDS + runner))))] + (for {@.old <jvm> + @.jvm <jvm> + + @.js + (..setTimeout [(ffi.closure [] (..execute! action)) + (n.frac milli_seconds)]) + + @.python + (do io.monad + [_ (|> (ffi.lambda [] (..execute! action)) + [(|> milli_seconds n.frac (f./ +1,000.0))] + threading/Timer::new + (threading/Timer::start []))] + (wrap []))} + + ## Default + (do {! io.monad} + [now (\ ! map (|>> instant.to_millis .nat) instant.now) + _ (atom.update (|>> (#.Cons {#creation now + #delay milli_seconds + #action action})) + ..runner)] + (wrap []))))) + +(for {@.old (as_is) + @.jvm (as_is) + @.js (as_is) + @.python (as_is)} + + ## Default + (as_is (exception: #export cannot_continue_running_threads) + + (def: #export run! + (IO Any) + (loop [_ []] + (do {! io.monad} + [threads (atom.read ..runner)] + (case threads + ## And... we're done! + #.Nil + (wrap []) + + _ + (do ! + [now (\ ! map (|>> instant.to_millis .nat) instant.now) + #let [[ready pending] (list.partition (function (_ thread) + (|> (get@ #creation thread) + (n.+ (get@ #delay thread)) + (n.<= now))) + threads)] + swapped? (atom.compare_and_swap threads pending ..runner)] + (if swapped? + (do ! + [_ (monad.map ! (|>> (get@ #action) ..execute! io.io) ready)] + (recur [])) + (error! (exception.construct ..cannot_continue_running_threads [])))) + )))) + )) diff --git a/stdlib/source/library/lux/control/continuation.lux b/stdlib/source/library/lux/control/continuation.lux new file mode 100644 index 000000000..8b9b5a24f --- /dev/null +++ b/stdlib/source/library/lux/control/continuation.lux @@ -0,0 +1,100 @@ +(.module: + [library + [lux #* + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)]] + [control + ["." function] + [parser + ["s" code]]] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code]]]]) + +(type: #export (Cont i o) + {#.doc "Continuations."} + (-> (-> i o) o)) + +(def: #export (continue next cont) + {#.doc "Continues a continuation thunk."} + (All [i o] (-> (-> i o) (Cont i o) o)) + (cont next)) + +(def: #export (run cont) + {#.doc "Forces a continuation thunk to be evaluated."} + (All [a] (-> (Cont a a) a)) + (cont function.identity)) + +(def: #export (call/cc f) + {#.doc "Call with current continuation."} + (All [a b z] + (-> (-> (-> a (Cont b z)) + (Cont a z)) + (Cont a z))) + (function (_ k) + (f (function (_ a) (function (_ _) (k a))) + k))) + +(syntax: #export (pending expr) + {#.doc (doc "Turns any expression into a function that is pending a continuation." + (pending (some_function some_input)))} + (with_gensyms [g!_ g!k] + (wrap (list (` (.function ((~ g!_) (~ g!k)) ((~ g!k) (~ expr)))))))) + +(def: #export (reset scope) + (All [i o] (-> (Cont i i) (Cont i o))) + (function (_ k) + (k (run scope)))) + +(def: #export (shift f) + (All [a] + (-> (-> (-> a (Cont a a)) + (Cont a a)) + (Cont a a))) + (function (_ oc) + (f (function (_ a) (function (_ ic) (ic (oc a)))) + function.identity))) + +(implementation: #export functor + (All [o] (Functor (All [i] (Cont i o)))) + + (def: (map f fv) + (function (_ k) (fv (function.compose k f))))) + +(implementation: #export apply + (All [o] (Apply (All [i] (Cont i o)))) + + (def: &functor ..functor) + + (def: (apply ff fv) + (function (_ k) + (|> (k (f v)) + (function (_ v)) fv + (function (_ f)) ff)))) + +(implementation: #export monad + (All [o] (Monad (All [i] (Cont i o)))) + + (def: &functor ..functor) + + (def: (wrap value) + (function (_ k) (k value))) + + (def: (join ffa) + (function (_ k) + (ffa (continue k))))) + +(def: #export (portal init) + (All [i o z] + (-> i + (Cont [(-> i (Cont o z)) + i] + z))) + (call/cc (function (_ k) + (do ..monad + [#let [nexus (function (nexus val) + (k [nexus val]))] + _ (k [nexus init])] + (wrap (undefined)))))) diff --git a/stdlib/source/library/lux/control/exception.lux b/stdlib/source/library/lux/control/exception.lux new file mode 100644 index 000000000..405c858a5 --- /dev/null +++ b/stdlib/source/library/lux/control/exception.lux @@ -0,0 +1,184 @@ +(.module: {#.doc "Exception-handling functionality."} + [library + [lux #* + ["." macro] + ["." meta] + [abstract + [monad (#+ do)]] + [control + ["p" parser + ["s" code (#+ Parser)]]] + [data + ["." maybe] + ["." product] + ["." text ("#\." monoid)] + [collection + ["." list ("#\." functor fold)]]] + [macro + ["." code] + [syntax (#+ syntax:) + ["|.|" export] + ["|.|" input] + ["." type #_ + ["|#_.|" variable]]]] + [math + [number + ["n" nat ("#\." decimal)]]]]] + [// + ["//" try (#+ Try)]]) + +(type: #export (Exception a) + {#.doc "An exception provides a way to decorate error messages."} + {#label Text + #constructor (-> a Text)}) + +(def: #export (match? exception error) + (All [e] (-> (Exception e) Text Bit)) + (text.starts_with? (get@ #label exception) error)) + +(def: #export (catch exception then try) + {#.doc (doc "If a particular exception is detected on a possibly-erroneous value, handle it." + "If no exception was detected, or a different one from the one being checked, then pass along the original value.")} + (All [e a] + (-> (Exception e) (-> Text a) (Try a) + (Try a))) + (case try + (#//.Success output) + (#//.Success output) + + (#//.Failure error) + (let [reference (get@ #label exception)] + (if (text.starts_with? reference error) + (#//.Success (|> error + (text.clip' (text.size reference)) + maybe.assume + then)) + (#//.Failure error))))) + +(def: #export (otherwise to_do try) + {#.doc "If no handler could be found to catch the exception, then run a function as a last-resort measure."} + (All [a] + (-> (-> Text a) (Try a) a)) + (case try + (#//.Success output) + output + + (#//.Failure error) + (to_do error))) + +(def: #export (return value) + {#.doc "A way to lift normal values into the error-handling context."} + (All [a] (-> a (Try a))) + (#//.Success value)) + +(def: #export (construct exception message) + {#.doc "Constructs an exception."} + (All [e] (-> (Exception e) e Text)) + ((get@ #..constructor exception) message)) + +(def: #export (throw exception message) + {#.doc "Decorate an error message with an Exception and lift it into the error-handling context."} + (All [e a] (-> (Exception e) e (Try a))) + (#//.Failure (..construct exception message))) + +(def: #export (assert exception message test) + (All [e] (-> (Exception e) e Bit (Try Any))) + (if test + (#//.Success []) + (..throw exception message))) + +(syntax: #export (exception: {export |export|.parser} + {t_vars (p.default (list) (s.tuple (p.some |type_variable|.parser)))} + {[name inputs] (p.either (p.and s.local_identifier (wrap (list))) + (s.form (p.and s.local_identifier (p.some |input|.parser))))} + {body (p.maybe s.any)}) + {#.doc (doc "Define a new exception type." + "It mostly just serves as a way to tag error messages for later catching." + "" + "Simple case:" + (exception: #export some_exception) + "" + "Complex case:" + (exception: #export [optional type variables] (some_exception {optional Text} {arguments Int}) + optional_body))} + (macro.with_gensyms [g!descriptor] + (do meta.monad + [current_module meta.current_module_name + #let [descriptor ($_ text\compose "{" current_module "." name "}" text.new_line) + g!self (code.local_identifier name)]] + (wrap (list (` (def: (~+ (|export|.format export)) + (~ g!self) + (All [(~+ (list\map |type_variable|.format t_vars))] + (..Exception [(~+ (list\map (get@ #|input|.type) inputs))])) + (let [(~ g!descriptor) (~ (code.text descriptor))] + {#..label (~ g!descriptor) + #..constructor (function ((~ g!self) [(~+ (list\map (get@ #|input|.binding) inputs))]) + ((~! text\compose) (~ g!descriptor) + (~ (maybe.default (' "") body))))}))))) + ))) + +(def: (report' entries) + (-> (List [Text Text]) Text) + (let [header_separator ": " + largest_header_size (list\fold (function (_ [header _] max) + (n.max (text.size header) max)) + 0 + entries) + on_new_line (|> " " + (list.repeat (n.+ (text.size header_separator) + largest_header_size)) + (text.join_with "") + (text\compose text.new_line))] + (|> entries + (list\map (function (_ [header message]) + (let [padding (|> " " + (list.repeat (n.- (text.size header) + largest_header_size)) + (text.join_with ""))] + (|> message + (text.replace_all text.new_line on_new_line) + ($_ text\compose padding header header_separator))))) + (text.join_with text.new_line)))) + +(syntax: #export (report {entries (p.many (s.tuple (p.and s.any s.any)))}) + (wrap (list (` ((~! report') (list (~+ (|> entries + (list\map (function (_ [header message]) + (` [(~ header) (~ message)]))))))))))) + +(def: #export (enumerate format entries) + (All [a] + (-> (-> a Text) (List a) Text)) + (|> entries + list.enumeration + (list\map (function (_ [index entry]) + [(n\encode index) (format entry)])) + report')) + +(def: separator + (let [gap ($_ "lux text concat" text.new_line text.new_line) + horizontal_line (|> "-" (list.repeat 64) (text.join_with ""))] + ($_ "lux text concat" + gap + horizontal_line + gap))) + +(def: (decorate prelude error) + (-> Text Text Text) + ($_ "lux text concat" + prelude + ..separator + error)) + +(def: #export (with exception message computation) + (All [e a] (-> (Exception e) e (Try a) (Try a))) + (case computation + (#//.Failure error) + (#//.Failure (case error + "" + (..construct exception message) + + _ + (..decorate (..construct exception message) error))) + + success + success)) diff --git a/stdlib/source/library/lux/control/function.lux b/stdlib/source/library/lux/control/function.lux new file mode 100644 index 000000000..2f880a872 --- /dev/null +++ b/stdlib/source/library/lux/control/function.lux @@ -0,0 +1,47 @@ +(.module: + [library + [lux #* + [abstract + [monoid (#+ Monoid)]]]]) + +(def: #export identity + {#.doc (doc "Identity function." + "Does nothing to its argument and just returns it." + (is? (identity value) + value))} + (All [a] (-> a a)) + (|>>)) + +(def: #export (compose f g) + {#.doc (doc "Function composition." + (= ((compose f g) "foo") + (f (g "foo"))))} + (All [a b c] + (-> (-> b c) (-> a b) (-> a c))) + (|>> g f)) + +(def: #export (constant value) + {#.doc (doc "Create constant functions." + (= ((constant "foo") "bar") + "foo"))} + (All [o] (-> o (All [i] (-> i o)))) + (function (_ _) value)) + +(def: #export (flip f) + {#.doc (doc "Flips the order of the arguments of a function." + (= ((flip f) "foo" "bar") + (f "bar" "foo")))} + (All [a b c] + (-> (-> a b c) (-> b a c))) + (function (_ x y) (f y x))) + +(def: #export (apply input function) + (All [i o] + (-> i (-> i o) o)) + (function input)) + +(implementation: #export monoid + (All [a] (Monoid (-> a a))) + + (def: identity ..identity) + (def: compose ..compose)) diff --git a/stdlib/source/library/lux/control/function/contract.lux b/stdlib/source/library/lux/control/function/contract.lux new file mode 100644 index 000000000..149053230 --- /dev/null +++ b/stdlib/source/library/lux/control/function/contract.lux @@ -0,0 +1,52 @@ +(.module: + [library + [lux #* + [control + ["." exception (#+ exception:)]] + [data + [text + ["%" format (#+ format)]]] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code]] + [math + [number + ["i" int]]]]]) + +(template [<name>] + [(exception: (<name> {condition Code}) + (exception.report + ["Condition" (%.code condition)]))] + + [pre_condition_failed] + [post_condition_failed] + ) + +(def: (assert! message test) + (-> Text Bit []) + (if test + [] + (error! message))) + +(syntax: #export (pre test expr) + {#.doc (doc "Pre-conditions." + "Given a test and an expression to run, only runs the expression if the test passes." + "Otherwise, an error is raised." + (pre (i.= +4 (i.+ +2 +2)) + (foo +123 +456 +789)))} + (wrap (list (` (exec ((~! ..assert!) (~ (code.text (exception.construct ..pre_condition_failed test))) + (~ test)) + (~ expr)))))) + +(syntax: #export (post test expr) + {#.doc (doc "Post-conditions." + "Given a predicate and an expression to run, evaluates the expression and then tests the output with the predicate." + "If the predicate returns #1, returns the value of the expression." + "Otherwise, an error is raised." + (post i.even? + (i.+ +2 +2)))} + (with_gensyms [g!output] + (wrap (list (` (let [(~ g!output) (~ expr)] + (exec ((~! ..assert!) (~ (code.text (exception.construct ..post_condition_failed test))) + ((~ test) (~ g!output))) + (~ g!output)))))))) diff --git a/stdlib/source/library/lux/control/function/memo.lux b/stdlib/source/library/lux/control/function/memo.lux new file mode 100644 index 000000000..5ab6c2b3b --- /dev/null +++ b/stdlib/source/library/lux/control/function/memo.lux @@ -0,0 +1,64 @@ +## Inspired by; +## "The Different Aspects of Monads and Mixins" by Bruno C. d. S. Oliveira + +(.module: + [library + [lux #* + [abstract + [hash (#+ Hash)] + [monad (#+ do)]] + [control + ["." state (#+ State)]] + [data + ["." product] + [collection + ["." dictionary (#+ Dictionary)]]]]] + ["." // #_ + ["#" mixin (#+ Mixin Recursive)]]) + +(def: #export memoization + (All [i o] + (Mixin i (State (Dictionary i o) o))) + (function (_ delegate recur) + (function (_ input) + (do {! state.monad} + [memory state.get] + (case (dictionary.get input memory) + (#.Some output) + (wrap output) + + #.None + (do ! + [output (delegate input) + _ (state.update (dictionary.put input output))] + (wrap output))))))) + +(type: #export (Memo i o) + (Recursive i (State (Dictionary i o) o))) + +(def: #export (open memo) + {#.doc (doc "Memoization where the memoized results can be re-used accross invocations.")} + (All [i o] + (:let [Memory (Dictionary i o)] + (-> (Memo i o) (-> [Memory i] [Memory o])))) + (let [memo (//.mixin (//.inherit ..memoization (//.from-recursive memo)))] + (function (_ [memory input]) + (|> input memo (state.run memory))))) + +(def: #export (closed hash memo) + {#.doc (doc "Memoization confined to a single invocation to the function (not counting any subsequent recursive invocations)." + "Memoized results will be re-used during recursive invocations, but cannot be accessed after the main invocation has ended.")} + (All [i o] + (-> (Hash i) (Memo i o) (-> i o))) + (let [memo (//.mixin (//.inherit ..memoization (//.from-recursive memo))) + empty (dictionary.new hash)] + (|>> memo (state.run empty) product.right))) + +(def: #export (none hash memo) + {#.doc (doc "No memoization at all." + "This is useful as a test control when measuring the effect of using memoization.")} + (All [i o] + (-> (Hash i) (Memo i o) (-> i o))) + (let [memo (//.mixin (//.from-recursive memo)) + empty (dictionary.new hash)] + (|>> memo (state.run empty) product.right))) diff --git a/stdlib/source/library/lux/control/function/mixin.lux b/stdlib/source/library/lux/control/function/mixin.lux new file mode 100644 index 000000000..f70b2f9c3 --- /dev/null +++ b/stdlib/source/library/lux/control/function/mixin.lux @@ -0,0 +1,64 @@ +## Inspired by; +## "The Different Aspects of Monads and Mixins" by Bruno C. d. S. Oliveira + +(.module: + [library + [lux #* + [abstract + [monoid (#+ Monoid)] + [predicate (#+ Predicate)] + [monad (#+ Monad do)]]]]) + +(type: #export (Mixin i o) + (-> (-> i o) (-> i o) (-> i o))) + +(def: #export (mixin f) + (All [i o] (-> (Mixin i o) (-> i o))) + (function (mix input) + ((f mix mix) input))) + +(def: #export nothing + Mixin + (function (_ delegate recur) + delegate)) + +(def: #export (inherit parent child) + (All [i o] (-> (Mixin i o) (Mixin i o) (Mixin i o))) + (function (_ delegate recur) + (parent (child delegate recur) recur))) + +(implementation: #export monoid + (All [i o] (Monoid (Mixin i o))) + + (def: identity ..nothing) + (def: compose ..inherit)) + +(def: #export (advice when then) + (All [i o] (-> (Predicate i) (Mixin i o) (Mixin i o))) + (function (_ delegate recur input) + (if (when input) + ((then delegate recur) input) + (delegate input)))) + +(def: #export (before monad action) + (All [! i o] (-> (Monad !) (-> i (! Any)) (Mixin i (! o)))) + (function (_ delegate recur input) + (do monad + [_ (action input)] + (delegate input)))) + +(def: #export (after monad action) + (All [! i o] (-> (Monad !) (-> i o (! Any)) (Mixin i (! o)))) + (function (_ delegate recur input) + (do monad + [output (delegate input) + _ (action input output)] + (wrap output)))) + +(type: #export (Recursive i o) + (-> (-> i o) (-> i o))) + +(def: #export (from-recursive recursive) + (All [i o] (-> (Recursive i o) (Mixin i o))) + (function (_ delegate recur) + (recursive recur))) diff --git a/stdlib/source/library/lux/control/function/mutual.lux b/stdlib/source/library/lux/control/function/mutual.lux new file mode 100644 index 000000000..dcc4791e1 --- /dev/null +++ b/stdlib/source/library/lux/control/function/mutual.lux @@ -0,0 +1,158 @@ +(.module: + [library + [lux (#- Definition let def:) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser ("#\." monad) + ["<.>" code (#+ Parser)]]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)] + [dictionary + ["." plist (#+ PList)]]]] + ["." macro + ["." local] + ["." code] + [syntax (#+ syntax:) + ["." export] + ["." declaration (#+ Declaration)]]]]] + ["." //]) + +(type: Mutual + {#declaration Declaration + #type Code + #body Code}) + +(.def: mutual + (Parser [Declaration Code Code]) + ($_ <>.and + declaration.parser + <code>.any + <code>.any + )) + +(.def: (mutual_definition context g!context [g!name mutual]) + (-> (List Code) Code [Code Mutual] Code) + (` (function ((~ g!name) (~ g!context)) + (.let [[(~+ context)] (~ g!context)] + (function (~ (declaration.format (get@ #declaration mutual))) + (~ (get@ #body mutual))))))) + +(.def: (macro g!context g!self) + (-> Code Code Macro) + (<| (:as Macro) + (: Macro') + (function (_ parameters) + (\ meta.monad wrap (list (` (((~ g!self) (~ g!context)) (~+ parameters)))))))) + +(syntax: #export (let {functions (<code>.tuple (<>.some ..mutual))} + body) + (case functions + #.Nil + (wrap (list body)) + + (#.Cons mutual #.Nil) + (.let [g!name (|> mutual (get@ [#declaration #declaration.name]) code.local_identifier)] + (wrap (list (` (.let [(~ g!name) (: (~ (get@ #type mutual)) + (function (~ (declaration.format (get@ #declaration mutual))) + (~ (get@ #body mutual))))] + (~ body)))))) + + _ + (macro.with_gensyms [g!context g!output] + (do {! meta.monad} + [here_name meta.current_module_name + hidden_names (monad.map ! (//.constant (macro.gensym "mutual_function#")) + functions) + #let [definitions (list\map (..mutual_definition hidden_names g!context) + (list.zip/2 hidden_names + functions)) + context_types (list\map (function (_ mutual) + (` (-> (~ g!context) (~ (get@ #type mutual))))) + functions) + user_names (list\map (|>> (get@ [#declaration #declaration.name]) code.local_identifier) + functions)] + g!pop (local.push (list\map (function (_ [g!name mutual]) + [[here_name (get@ [#declaration #declaration.name] mutual)] + (..macro g!context g!name)]) + (list.zip/2 hidden_names + functions)))] + (wrap (list (` (.let [(~ g!context) (: (Rec (~ g!context) + [(~+ context_types)]) + [(~+ definitions)]) + [(~+ user_names)] (.let [[(~+ user_names)] (~ g!context)] + [(~+ (list\map (function (_ g!name) + (` ((~ g!name) (~ g!context)))) + user_names))]) + (~ g!output) (~ body)] + (exec (~ g!pop) + (~ g!output)))))))))) + +(type: Definition + {#exported? Bit + #mutual Mutual}) + +(.def: definition + (Parser Definition) + (<code>.tuple (<>.and export.parser + ..mutual))) + +(syntax: #export (def: {functions (<>.many ..definition)}) + (case functions + #.Nil + (wrap (list)) + + (#.Cons definition #.Nil) + (.let [(^slots [#exported? #mutual]) definition + (^slots [#declaration #type #body]) mutual] + (wrap (list (` (.def: + (~+ (export.format exported?)) + (~ (declaration.format declaration)) + (~ type) + (~ body)))))) + + _ + (macro.with_gensyms [g!context g!output] + (do {! meta.monad} + [here_name meta.current_module_name + hidden_names (monad.map ! (//.constant (macro.gensym "mutual_function#")) + functions) + #let [definitions (list\map (..mutual_definition hidden_names g!context) + (list.zip/2 hidden_names + (list\map (get@ #mutual) functions))) + context_types (list\map (function (_ mutual) + (` (-> (~ g!context) (~ (get@ [#mutual #type] mutual))))) + functions) + user_names (list\map (|>> (get@ [#mutual #declaration #declaration.name]) code.local_identifier) + functions)] + g!pop (local.push (list\map (function (_ [g!name mutual]) + [[here_name (get@ [#mutual #declaration #declaration.name] mutual)] + (..macro g!context g!name)]) + (list.zip/2 hidden_names + functions)))] + (wrap (list& (` (.def: (~ g!context) + [(~+ (list\map (get@ [#mutual #type]) functions))] + (.let [(~ g!context) (: (Rec (~ g!context) + [(~+ context_types)]) + [(~+ definitions)]) + [(~+ user_names)] (~ g!context)] + [(~+ (list\map (function (_ g!name) + (` ((~ g!name) (~ g!context)))) + user_names))]))) + g!pop + (list\map (function (_ mutual) + (.let [g!name (|> mutual (get@ [#mutual #declaration #declaration.name]) code.local_identifier)] + (` (.def: + (~+ (export.format (get@ #exported? mutual))) + (~ g!name) + (~ (get@ [#mutual #type] mutual)) + (.let [[(~+ user_names)] (~ g!context)] + (~ g!name)))))) + functions))))))) diff --git a/stdlib/source/library/lux/control/io.lux b/stdlib/source/library/lux/control/io.lux new file mode 100644 index 000000000..a4773cd0d --- /dev/null +++ b/stdlib/source/library/lux/control/io.lux @@ -0,0 +1,72 @@ +(.module: {#.doc "A method for abstracting I/O and effectful computations to make it safe while writing pure functional code."} + [library + [lux #* + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)]] + [control + [parser + ["s" code]]] + [type + abstract] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." template]]]]) + +(abstract: #export (IO a) + (-> Any a) + + {#.doc "A type that represents synchronous, effectful computations that may interact with the outside world."} + + (def: label + (All [a] (-> (-> Any a) (IO a))) + (|>> :abstraction)) + + (template: (!io computation) + (:abstraction (template.with_locals [g!func g!arg] + (function (g!func g!arg) + computation)))) + + (template: (!run io) + ## creatio ex nihilo + ((:representation io) [])) + + (syntax: #export (io computation) + {#.doc (doc "Delays the evaluation of an expression, by wrapping it in an IO 'thunk'." + "Great for wrapping effectful computations (which will not be performed until the IO is 'run')." + (io (exec + (log! msg) + "Some value...")))} + (with_gensyms [g!func g!arg] + (wrap (list (` ((~! ..label) (function ((~ g!func) (~ g!arg)) + (~ computation)))))))) + + (def: #export run + {#.doc "A way to execute IO computations and perform their side-effects."} + (All [a] (-> (IO a) a)) + (|>> !run)) + + (implementation: #export functor + (Functor IO) + + (def: (map f) + (|>> !run f !io))) + + (implementation: #export apply + (Apply IO) + + (def: &functor ..functor) + + (def: (apply ff fa) + (!io ((!run ff) (!run fa))))) + + (implementation: #export monad + (Monad IO) + + (def: &functor ..functor) + + (def: wrap (|>> !io)) + + (def: join (|>> !run !run !io))) + ) diff --git a/stdlib/source/library/lux/control/parser.lux b/stdlib/source/library/lux/control/parser.lux new file mode 100644 index 000000000..fad957e27 --- /dev/null +++ b/stdlib/source/library/lux/control/parser.lux @@ -0,0 +1,324 @@ +(.module: + [library + [lux (#- or and not) + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)] + [codec (#+ Codec)]] + [control + ["." try (#+ Try)]] + [data + ["." product] + [collection + ["." list ("#\." functor monoid)]]] + [math + [number + ["n" nat]]]]]) + +(type: #export (Parser s a) + {#.doc "A generic parser."} + (-> s (Try [s a]))) + +(implementation: #export functor + (All [s] (Functor (Parser s))) + + (def: (map f ma) + (function (_ input) + (case (ma input) + (#try.Failure msg) + (#try.Failure msg) + + (#try.Success [input' a]) + (#try.Success [input' (f a)]))))) + +(implementation: #export apply + (All [s] (Apply (Parser s))) + + (def: &functor ..functor) + + (def: (apply ff fa) + (function (_ input) + (case (ff input) + (#try.Success [input' f]) + (case (fa input') + (#try.Success [input'' a]) + (#try.Success [input'' (f a)]) + + (#try.Failure msg) + (#try.Failure msg)) + + (#try.Failure msg) + (#try.Failure msg))))) + +(implementation: #export monad + (All [s] (Monad (Parser s))) + + (def: &functor ..functor) + + (def: (wrap x) + (function (_ input) + (#try.Success [input x]))) + + (def: (join mma) + (function (_ input) + (case (mma input) + (#try.Failure msg) + (#try.Failure msg) + + (#try.Success [input' ma]) + (ma input'))))) + +(def: #export (assert message test) + {#.doc "Fails with the given message if the test is #0."} + (All [s] (-> Text Bit (Parser s Any))) + (function (_ input) + (if test + (#try.Success [input []]) + (#try.Failure message)))) + +(def: #export (maybe parser) + {#.doc "Optionality combinator."} + (All [s a] + (-> (Parser s a) (Parser s (Maybe a)))) + (function (_ input) + (case (parser input) + (#try.Failure _) + (#try.Success [input #.None]) + + (#try.Success [input' x]) + (#try.Success [input' (#.Some x)])))) + +(def: #export (run parser input) + (All [s a] + (-> (Parser s a) s (Try [s a]))) + (parser input)) + +(def: #export (and first second) + {#.doc "Sequencing combinator."} + (All [s a b] + (-> (Parser s a) (Parser s b) (Parser s [a b]))) + (do {! ..monad} + [head first] + (\ ! map (|>> [head]) second))) + +(def: #export (or left right) + {#.doc "Heterogeneous alternative combinator."} + (All [s a b] + (-> (Parser s a) (Parser s b) (Parser s (| a b)))) + (function (_ tokens) + (case (left tokens) + (#try.Success [tokens' output]) + (#try.Success [tokens' (0 #0 output)]) + + (#try.Failure _) + (case (right tokens) + (#try.Success [tokens' output]) + (#try.Success [tokens' (0 #1 output)]) + + (#try.Failure error) + (#try.Failure error))))) + +(def: #export (either this that) + {#.doc "Homogeneous alternative combinator."} + (All [s a] + (-> (Parser s a) (Parser s a) (Parser s a))) + (function (_ tokens) + (case (this tokens) + (#try.Failure _) + (that tokens) + + output + output))) + +(def: #export (some parser) + {#.doc "0-or-more combinator."} + (All [s a] + (-> (Parser s a) (Parser s (List a)))) + (function (_ input) + (case (parser input) + (#try.Failure _) + (#try.Success [input (list)]) + + (#try.Success [input' head]) + (..run (\ ..monad map (|>> (list& head)) + (some parser)) + input')))) + +(def: #export (many parser) + {#.doc "1-or-more combinator."} + (All [s a] + (-> (Parser s a) (Parser s (List a)))) + (|> (..some parser) + (..and parser) + (\ ..monad map (|>> #.Cons)))) + +(def: #export (exactly amount parser) + {#.doc "Parse exactly N times."} + (All [s a] (-> Nat (Parser s a) (Parser s (List a)))) + (case amount + 0 (\ ..monad wrap (list)) + _ (do {! ..monad} + [x parser] + (|> parser + (exactly (dec amount)) + (\ ! map (|>> (#.Cons x))))))) + +(def: #export (at_least amount parser) + {#.doc "Parse at least N times."} + (All [s a] (-> Nat (Parser s a) (Parser s (List a)))) + (do {! ..monad} + [minimum (..exactly amount parser)] + (\ ! map (list\compose minimum) (..some parser)))) + +(def: #export (at_most amount parser) + {#.doc "Parse at most N times."} + (All [s a] (-> Nat (Parser s a) (Parser s (List a)))) + (case amount + 0 (\ ..monad wrap (list)) + _ (function (_ input) + (case (parser input) + (#try.Failure msg) + (#try.Success [input (list)]) + + (#try.Success [input' x]) + (..run (\ ..monad map (|>> (#.Cons x)) + (at_most (dec amount) parser)) + input'))))) + +(def: #export (between from to parser) + {#.doc "Parse between N and M times."} + (All [s a] (-> Nat Nat (Parser s a) (Parser s (List a)))) + (do {! ..monad} + [minimum (..exactly from parser)] + (if (n.< to from) + (\ ! map (list\compose minimum) + (..at_most (n.- from to) parser)) + (wrap minimum)))) + +(def: #export (separated_by separator parser) + {#.doc "Parsers instances of 'parser' that are separated by instances of 'separator'."} + (All [s a b] (-> (Parser s b) (Parser s a) (Parser s (List a)))) + (do {! ..monad} + [?x (..maybe parser)] + (case ?x + #.None + (wrap #.Nil) + + (#.Some x) + (|> parser + (..and separator) + ..some + (\ ! map (|>> (list\map product.right) (#.Cons x))))))) + +(def: #export (not parser) + (All [s a] (-> (Parser s a) (Parser s Any))) + (function (_ input) + (case (parser input) + (#try.Failure msg) + (#try.Success [input []]) + + _ + (#try.Failure "Expected to fail; yet succeeded.")))) + +(def: #export (fail message) + (All [s a] (-> Text (Parser s a))) + (function (_ input) + (#try.Failure message))) + +(def: #export (lift operation) + (All [s a] (-> (Try a) (Parser s a))) + (function (_ input) + (case operation + (#try.Success output) + (#try.Success [input output]) + + (#try.Failure error) + (#try.Failure error)))) + +(def: #export (default value parser) + {#.doc "If the given parser fails, returns the default value."} + (All [s a] (-> a (Parser s a) (Parser s a))) + (function (_ input) + (case (parser input) + (#try.Failure error) + (#try.Success [input value]) + + (#try.Success [input' output]) + (#try.Success [input' output])))) + +(def: #export remaining + (All [s] (Parser s s)) + (function (_ inputs) + (#try.Success [inputs inputs]))) + +(def: #export (rec parser) + {#.doc "Combinator for recursive parser."} + (All [s a] (-> (-> (Parser s a) (Parser s a)) (Parser s a))) + (function (_ inputs) + (..run (parser (rec parser)) inputs))) + +(def: #export (after param subject) + (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a))) + (do ..monad + [_ param] + subject)) + +(def: #export (before param subject) + (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a))) + (do ..monad + [output subject + _ param] + (wrap output))) + +(def: #export (filter test parser) + (All [s a] (-> (-> a Bit) (Parser s a) (Parser s a))) + (do ..monad + [output parser + _ (..assert "Constraint failed." (test output))] + (wrap output))) + +(def: #export (parses? parser) + (All [s a] (-> (Parser s a) (Parser s Bit))) + (function (_ input) + (case (parser input) + (#try.Failure error) + (#try.Success [input false]) + + (#try.Success [input' _]) + (#try.Success [input' true])))) + +(def: #export (parses parser) + (All [s a] (-> (Parser s a) (Parser s Any))) + (function (_ input) + (case (parser input) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [input' _]) + (#try.Success [input' []])))) + +(def: #export (speculative parser) + (All [s a] (-> (Parser s a) (Parser s a))) + (function (_ input) + (case (parser input) + (#try.Success [input' output]) + (#try.Success [input output]) + + output + output))) + +(def: #export (codec codec parser) + (All [s a z] (-> (Codec a z) (Parser s a) (Parser s z))) + (function (_ input) + (case (parser input) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [input' to_decode]) + (case (\ codec decode to_decode) + (#try.Failure error) + (#try.Failure error) + + (#try.Success value) + (#try.Success [input' value]))))) diff --git a/stdlib/source/library/lux/control/parser/analysis.lux b/stdlib/source/library/lux/control/parser/analysis.lux new file mode 100644 index 000000000..cdfb18504 --- /dev/null +++ b/stdlib/source/library/lux/control/parser/analysis.lux @@ -0,0 +1,135 @@ +(.module: + [library + [lux (#- nat int rev) + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." bit] + ["." name] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)]]] + [math + [number + ["." i64] + ["." nat] + ["." int] + ["." rev] + ["." frac]]] + [tool + [compiler + [arity (#+ Arity)] + [reference (#+) + [variable (#+)]] + [language + [lux + ["/" analysis (#+ Variant Tuple Environment Analysis)]]]]]]] + ["." //]) + +(def: (remaining_inputs asts) + (-> (List Analysis) Text) + (format text.new_line "Remaining input: " + (|> asts + (list\map /.%analysis) + (list.interpose " ") + (text.join_with "")))) + +(exception: #export (cannot_parse {input (List Analysis)}) + (exception.report + ["Input" (exception.enumerate /.%analysis input)])) + +(exception: #export (unconsumed_input {input (List Analysis)}) + (exception.report + ["Input" (exception.enumerate /.%analysis input)])) + +(type: #export Parser + (//.Parser (List Analysis))) + +(def: #export (run parser input) + (All [a] (-> (Parser a) (List Analysis) (Try a))) + (case (parser input) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [#.Nil value]) + (#try.Success value) + + (#try.Success [unconsumed _]) + (exception.throw ..unconsumed_input unconsumed))) + +(def: #export any + (Parser Analysis) + (function (_ input) + (case input + #.Nil + (exception.throw ..cannot_parse input) + + (#.Cons [head tail]) + (#try.Success [tail head])))) + +(def: #export end! + {#.doc "Ensures there are no more inputs."} + (Parser Any) + (function (_ tokens) + (case tokens + #.Nil (#try.Success [tokens []]) + _ (#try.Failure (format "Expected list of tokens to be empty!" + (remaining_inputs tokens)))))) + +(def: #export end? + {#.doc "Checks whether there are no more inputs."} + (Parser Bit) + (function (_ tokens) + (#try.Success [tokens (case tokens + #.Nil true + _ false)]))) + +(template [<query> <assertion> <tag> <type> <eq>] + [(def: #export <query> + (Parser <type>) + (function (_ input) + (case input + (^ (list& (<tag> x) input')) + (#try.Success [input' x]) + + _ + (exception.throw ..cannot_parse input)))) + + (def: #export (<assertion> expected) + (-> <type> (Parser Any)) + (function (_ input) + (case input + (^ (list& (<tag> actual) input')) + (if (\ <eq> = expected actual) + (#try.Success [input' []]) + (exception.throw ..cannot_parse input)) + + _ + (exception.throw ..cannot_parse input))))] + + [bit bit! /.bit Bit bit.equivalence] + [nat nat! /.nat Nat nat.equivalence] + [int int! /.int Int int.equivalence] + [rev rev! /.rev Rev rev.equivalence] + [frac frac! /.frac Frac frac.equivalence] + [text text! /.text Text text.equivalence] + [local local! /.variable/local Nat nat.equivalence] + [foreign foreign! /.variable/foreign Nat nat.equivalence] + [constant constant! /.constant Name name.equivalence] + ) + +(def: #export (tuple parser) + (All [a] (-> (Parser a) (Parser a))) + (function (_ input) + (case input + (^ (list& (/.tuple head) tail)) + (do try.monad + [output (..run parser head)] + (#try.Success [tail output])) + + _ + (exception.throw ..cannot_parse input)))) diff --git a/stdlib/source/library/lux/control/parser/binary.lux b/stdlib/source/library/lux/control/parser/binary.lux new file mode 100644 index 000000000..af28caeae --- /dev/null +++ b/stdlib/source/library/lux/control/parser/binary.lux @@ -0,0 +1,275 @@ +(.module: + [library + [lux (#- and or nat int rev list type) + [type (#+ :share)] + [abstract + [hash (#+ Hash)] + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["/" binary (#+ Binary)] + [text + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." list] + ["." row (#+ Row)] + ["." set (#+ Set)]]] + [macro + ["." template]] + [math + [number + ["n" nat] + ["." frac]]]]] + ["." // ("#\." monad)]) + +(type: #export Offset Nat) + +(type: #export Parser + (//.Parser [Offset Binary])) + +(exception: #export (binary_was_not_fully_read {binary_length Nat} {bytes_read Nat}) + (exception.report + ["Binary length" (%.nat binary_length)] + ["Bytes read" (%.nat bytes_read)])) + +(def: #export (run parser input) + (All [a] (-> (Parser a) Binary (Try a))) + (case (parser [0 input]) + (#try.Failure msg) + (#try.Failure msg) + + (#try.Success [[end _] output]) + (let [length (/.size input)] + (if (n.= end length) + (#try.Success output) + (exception.throw ..binary_was_not_fully_read [length end]))))) + +(def: #export end? + (Parser Bit) + (function (_ (^@ input [offset data])) + (#try.Success [input (n.= offset (/.size data))]))) + +(def: #export offset + (Parser Offset) + (function (_ (^@ input [offset data])) + (#try.Success [input offset]))) + +(def: #export remaining + (Parser Nat) + (function (_ (^@ input [offset data])) + (#try.Success [input (n.- offset (/.size data))]))) + +(type: #export Size Nat) + +(def: #export size/8 Size 1) +(def: #export size/16 Size (n.* 2 size/8)) +(def: #export size/32 Size (n.* 2 size/16)) +(def: #export size/64 Size (n.* 2 size/32)) + +(template [<name> <size> <read>] + [(def: #export <name> + (Parser I64) + (function (_ [offset binary]) + (case (<read> offset binary) + (#try.Success data) + (#try.Success [(n.+ <size> offset) binary] data) + + (#try.Failure error) + (#try.Failure error))))] + + [bits/8 ..size/8 /.read/8] + [bits/16 ..size/16 /.read/16] + [bits/32 ..size/32 /.read/32] + [bits/64 ..size/64 /.read/64] + ) + +(template [<name> <type>] + [(def: #export <name> (Parser <type>) ..bits/64)] + + [nat Nat] + [int Int] + [rev Rev] + ) + +(def: #export frac + (Parser Frac) + (//\map frac.from_bits ..bits/64)) + +(exception: #export (invalid_tag {range Nat} {byte Nat}) + (exception.report + ["Tag range" (%.nat range)] + ["Tag value" (%.nat byte)])) + +(template: (!variant <case>+) + (do {! //.monad} + [flag (: (Parser Nat) + ..bits/8)] + (`` (case flag + (^template [<number> <tag> <parser>] + [<number> (\ ! map (|>> <tag>) <parser>)]) + ((~~ (template.splice <case>+))) + _ (//.lift (exception.throw ..invalid_tag [(~~ (template.count <case>+)) flag])))))) + +(def: #export (or left right) + (All [l r] (-> (Parser l) (Parser r) (Parser (| l r)))) + (!variant [[0 #.Left left] + [1 #.Right right]])) + +(def: #export (rec body) + (All [a] (-> (-> (Parser a) (Parser a)) (Parser a))) + (function (_ input) + (let [parser (body (rec body))] + (parser input)))) + +(def: #export any + (Parser Any) + (//\wrap [])) + +(exception: #export (not_a_bit {value Nat}) + (exception.report + ["Expected values" "either 0 or 1"] + ["Actual value" (%.nat value)])) + +(def: #export bit + (Parser Bit) + (do //.monad + [value (: (Parser Nat) + ..bits/8)] + (case value + 0 (wrap #0) + 1 (wrap #1) + _ (//.lift (exception.throw ..not_a_bit [value]))))) + +(def: #export (segment size) + (-> Nat (Parser Binary)) + (function (_ [offset binary]) + (case size + 0 (#try.Success [[offset binary] (/.create 0)]) + _ (|> binary + (/.slice offset size) + (\ try.monad map (|>> [[(n.+ size offset) binary]])))))) + +(template [<name> <bits>] + [(def: #export <name> + (Parser Binary) + (do //.monad + [size (//\map .nat <bits>)] + (..segment size)))] + + [binary/8 ..bits/8] + [binary/16 ..bits/16] + [binary/32 ..bits/32] + [binary/64 ..bits/64] + ) + +(template [<name> <binary>] + [(def: #export <name> + (Parser Text) + (do //.monad + [utf8 <binary>] + (//.lift (\ utf8.codec decode utf8))))] + + [utf8/8 ..binary/8] + [utf8/16 ..binary/16] + [utf8/32 ..binary/32] + [utf8/64 ..binary/64] + ) + +(def: #export text ..utf8/64) + +(template [<name> <bits>] + [(def: #export (<name> valueP) + (All [v] (-> (Parser v) (Parser (Row v)))) + (do //.monad + [count (: (Parser Nat) + <bits>)] + (loop [index 0 + output (:share [v] + (Parser v) + valueP + + (Row v) + row.empty)] + (if (n.< count index) + (do //.monad + [value valueP] + (recur (.inc index) + (row.add value output))) + (//\wrap output)))))] + + [row/8 ..bits/8] + [row/16 ..bits/16] + [row/32 ..bits/32] + [row/64 ..bits/64] + ) + +(def: #export maybe + (All [a] (-> (Parser a) (Parser (Maybe a)))) + (..or ..any)) + +(def: #export (list value) + (All [a] (-> (Parser a) (Parser (List a)))) + (..rec + (|>> (//.and value) + (..or ..any)))) + +(exception: #export set_elements_are_not_unique) + +(def: #export (set hash value) + (All [a] (-> (Hash a) (Parser a) (Parser (Set a)))) + (do //.monad + [raw (..list value) + #let [output (set.from_list hash raw)] + _ (//.assert (exception.construct ..set_elements_are_not_unique []) + (n.= (list.size raw) + (set.size output)))] + (wrap output))) + +(def: #export name + (Parser Name) + (//.and ..text ..text)) + +(def: #export type + (Parser Type) + (..rec + (function (_ type) + (let [pair (//.and type type) + indexed ..nat + quantified (//.and (..list type) type)] + (!variant [[0 #.Primitive (//.and ..text (..list type))] + [1 #.Sum pair] + [2 #.Product pair] + [3 #.Function pair] + [4 #.Parameter indexed] + [5 #.Var indexed] + [6 #.Ex indexed] + [7 #.UnivQ quantified] + [8 #.ExQ quantified] + [9 #.Apply pair] + [10 #.Named (//.and ..name type)]]))))) + +(def: #export location + (Parser Location) + ($_ //.and ..text ..nat ..nat)) + +(def: #export code + (Parser Code) + (..rec + (function (_ recur) + (let [sequence (..list recur)] + (//.and ..location + (!variant [[0 #.Bit ..bit] + [1 #.Nat ..nat] + [2 #.Int ..int] + [3 #.Rev ..rev] + [4 #.Frac ..frac] + [5 #.Text ..text] + [6 #.Identifier ..name] + [7 #.Tag ..name] + [8 #.Form sequence] + [9 #.Tuple sequence] + [10 #.Record (..list (//.and recur recur))]])))))) diff --git a/stdlib/source/library/lux/control/parser/cli.lux b/stdlib/source/library/lux/control/parser/cli.lux new file mode 100644 index 000000000..34b061afc --- /dev/null +++ b/stdlib/source/library/lux/control/parser/cli.lux @@ -0,0 +1,99 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)]] + [data + ["." text ("#\." equivalence) + ["%" format (#+ format)]]]]] + ["." //]) + +(type: #export (Parser a) + {#.doc "A command-line interface parser."} + (//.Parser (List Text) a)) + +(def: #export (run parser inputs) + (All [a] (-> (Parser a) (List Text) (Try a))) + (case (//.run parser inputs) + (#try.Success [remaining output]) + (case remaining + #.Nil + (#try.Success output) + + _ + (#try.Failure (format "Remaining CLI inputs: " (text.join_with " " remaining)))) + + (#try.Failure try) + (#try.Failure try))) + +(def: #export any + {#.doc "Just returns the next input without applying any logic."} + (Parser Text) + (function (_ inputs) + (case inputs + (#.Cons arg inputs') + (#try.Success [inputs' arg]) + + _ + (#try.Failure "Cannot parse empty arguments.")))) + +(def: #export (parse parser) + {#.doc "Parses the next input with a parsing function."} + (All [a] (-> (-> Text (Try a)) (Parser a))) + (function (_ inputs) + (do try.monad + [[remaining raw] (any inputs) + output (parser raw)] + (wrap [remaining output])))) + +(def: #export (this reference) + {#.doc "Checks that a token is in the inputs."} + (-> Text (Parser Any)) + (function (_ inputs) + (do try.monad + [[remaining raw] (any inputs)] + (if (text\= reference raw) + (wrap [remaining []]) + (try.fail (format "Missing token: '" reference "'")))))) + +(def: #export (somewhere cli) + {#.doc "Given a parser, tries to parse it somewhere in the inputs (i.e. not necessarily parsing the immediate inputs)."} + (All [a] (-> (Parser a) (Parser a))) + (function (_ inputs) + (loop [immediate inputs] + (case (//.run cli immediate) + (#try.Success [remaining output]) + (#try.Success [remaining output]) + + (#try.Failure try) + (case immediate + #.Nil + (#try.Failure try) + + (#.Cons to_omit immediate') + (do try.monad + [[remaining output] (recur immediate')] + (wrap [(#.Cons to_omit remaining) + output]))))))) + +(def: #export end + {#.doc "Ensures there are no more inputs."} + (Parser Any) + (function (_ inputs) + (case inputs + #.Nil (#try.Success [inputs []]) + _ (#try.Failure (format "Unknown parameters: " (text.join_with " " inputs)))))) + +(def: #export (named name value) + (All [a] (-> Text (Parser a) (Parser a))) + (|> value + (//.after (..this name)) + ..somewhere)) + +(def: #export (parameter [short long] value) + (All [a] (-> [Text Text] (Parser a) (Parser a))) + (|> value + (//.after (//.either (..this short) (..this long))) + ..somewhere)) diff --git a/stdlib/source/library/lux/control/parser/code.lux b/stdlib/source/library/lux/control/parser/code.lux new file mode 100644 index 000000000..bb37c1faf --- /dev/null +++ b/stdlib/source/library/lux/control/parser/code.lux @@ -0,0 +1,199 @@ +(.module: + [library + [lux (#- nat int rev) + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)]] + [data + ["." bit] + ["." text ("#\." monoid)] + ["." name] + [collection + ["." list ("#\." functor)]]] + [macro + ["." code ("#\." equivalence)]] + [math + [number + ["." nat] + ["." int] + ["." rev] + ["." frac]]]]] + ["." //]) + +(def: (join_pairs pairs) + (All [a] (-> (List [a a]) (List a))) + (case pairs + #.Nil #.Nil + (#.Cons [[x y] pairs']) (list& x y (join_pairs pairs')))) + +(type: #export Parser + {#.doc "A Lux syntax parser."} + (//.Parser (List Code))) + +(def: (remaining_inputs asts) + (-> (List Code) Text) + ($_ text\compose text.new_line "Remaining input: " + (|> asts (list\map code.format) (list.interpose " ") (text.join_with "")))) + +(def: #export any + {#.doc "Just returns the next input without applying any logic."} + (Parser Code) + (function (_ tokens) + (case tokens + #.Nil + (#try.Failure "There are no tokens to parse!") + + (#.Cons [t tokens']) + (#try.Success [tokens' t])))) + +(template [<query> <check> <type> <tag> <eq> <desc>] + [(with_expansions [<failure> (as_is (#try.Failure ($_ text\compose "Cannot parse " <desc> (remaining_inputs tokens))))] + (def: #export <query> + {#.doc (code.text ($_ text\compose "Parses the next " <desc> " input."))} + (Parser <type>) + (function (_ tokens) + (case tokens + (#.Cons [[_ (<tag> x)] tokens']) + (#try.Success [tokens' x]) + + _ + <failure>))) + + (def: #export (<check> expected) + (-> <type> (Parser Any)) + (function (_ tokens) + (case tokens + (#.Cons [[_ (<tag> actual)] tokens']) + (if (\ <eq> = expected actual) + (#try.Success [tokens' []]) + <failure>) + + _ + <failure>))))] + + [bit bit! Bit #.Bit bit.equivalence "bit"] + [nat nat! Nat #.Nat nat.equivalence "nat"] + [int int! Int #.Int int.equivalence "int"] + [rev rev! Rev #.Rev rev.equivalence "rev"] + [frac frac! Frac #.Frac frac.equivalence "frac"] + [text text! Text #.Text text.equivalence "text"] + [identifier identifier! Name #.Identifier name.equivalence "identifier"] + [tag tag! Name #.Tag name.equivalence "tag"] + ) + +(def: #export (this! ast) + {#.doc "Ensures the given Code is the next input."} + (-> Code (Parser Any)) + (function (_ tokens) + (case tokens + (#.Cons [token tokens']) + (if (code\= ast token) + (#try.Success [tokens' []]) + (#try.Failure ($_ text\compose "Expected a " (code.format ast) " but instead got " (code.format token) + (remaining_inputs tokens)))) + + _ + (#try.Failure "There are no tokens to parse!")))) + +(template [<query> <check> <tag> <eq> <desc>] + [(with_expansions [<failure> (as_is (#try.Failure ($_ text\compose "Cannot parse " <desc> (remaining_inputs tokens))))] + (def: #export <query> + {#.doc (code.text ($_ text\compose "Parse a local " <desc> " (a " <desc> " that has no module prefix)."))} + (Parser Text) + (function (_ tokens) + (case tokens + (#.Cons [[_ (<tag> ["" x])] tokens']) + (#try.Success [tokens' x]) + + _ + <failure>))) + + (def: #export (<check> expected) + (-> Text (Parser Any)) + (function (_ tokens) + (case tokens + (#.Cons [[_ (<tag> ["" actual])] tokens']) + (if (\ <eq> = expected actual) + (#try.Success [tokens' []]) + <failure>) + + _ + <failure>))))] + + [local_identifier local_identifier! #.Identifier text.equivalence "local identifier"] + [ local_tag local_tag! #.Tag text.equivalence "local tag"] + ) + +(template [<name> <tag> <desc>] + [(def: #export (<name> p) + {#.doc (code.text ($_ text\compose "Parse inside the contents of a " <desc> " as if they were the input Codes."))} + (All [a] + (-> (Parser a) (Parser a))) + (function (_ tokens) + (case tokens + (#.Cons [[_ (<tag> members)] tokens']) + (case (p members) + (#try.Success [#.Nil x]) (#try.Success [tokens' x]) + _ (#try.Failure ($_ text\compose "Parser was expected to fully consume " <desc> (remaining_inputs tokens)))) + + _ + (#try.Failure ($_ text\compose "Cannot parse " <desc> (remaining_inputs tokens))))))] + + [ form #.Form "form"] + [tuple #.Tuple "tuple"] + ) + +(def: #export (record p) + {#.doc (code.text ($_ text\compose "Parse inside the contents of a record as if they were the input Codes."))} + (All [a] + (-> (Parser a) (Parser a))) + (function (_ tokens) + (case tokens + (#.Cons [[_ (#.Record pairs)] tokens']) + (case (p (join_pairs pairs)) + (#try.Success [#.Nil x]) (#try.Success [tokens' x]) + _ (#try.Failure ($_ text\compose "Parser was expected to fully consume record" (remaining_inputs tokens)))) + + _ + (#try.Failure ($_ text\compose "Cannot parse record" (remaining_inputs tokens)))))) + +(def: #export end! + {#.doc "Ensures there are no more inputs."} + (Parser Any) + (function (_ tokens) + (case tokens + #.Nil (#try.Success [tokens []]) + _ (#try.Failure ($_ text\compose "Expected list of tokens to be empty!" (remaining_inputs tokens)))))) + +(def: #export end? + {#.doc "Checks whether there are no more inputs."} + (Parser Bit) + (function (_ tokens) + (#try.Success [tokens (case tokens + #.Nil true + _ false)]))) + +(def: #export (run syntax inputs) + (All [a] (-> (Parser a) (List Code) (Try a))) + (case (syntax inputs) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [unconsumed value]) + (case unconsumed + #.Nil + (#try.Success value) + + _ + (#try.Failure (text\compose "Unconsumed inputs: " + (|> (list\map code.format unconsumed) + (text.join_with ", "))))))) + +(def: #export (local inputs syntax) + {#.doc "Run a syntax parser with the given list of inputs, instead of the real ones."} + (All [a] (-> (List Code) (Parser a) (Parser a))) + (function (_ real) + (do try.monad + [value (..run syntax inputs)] + (wrap [real value])))) diff --git a/stdlib/source/library/lux/control/parser/environment.lux b/stdlib/source/library/lux/control/parser/environment.lux new file mode 100644 index 000000000..c0ced37c2 --- /dev/null +++ b/stdlib/source/library/lux/control/parser/environment.lux @@ -0,0 +1,44 @@ +(.module: + [library + [lux #* + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary (#+ Dictionary)]]]]] + ["." //]) + +(type: #export Property + Text) + +(type: #export Environment + (Dictionary Property Text)) + +(exception: #export (unknown {property Property}) + (exception.report + ["Property" (%.text property)])) + +(type: #export (Parser a) + (//.Parser Environment a)) + +(def: #export empty + Environment + (dictionary.new text.hash)) + +(def: #export (property name) + (-> Text (Parser Text)) + (function (_ environment) + (case (dictionary.get name environment) + (#.Some value) + (exception.return [environment value]) + + #.None + (exception.throw ..unknown name)))) + +(def: #export (run parser environment) + (All [a] (-> (Parser a) Environment (Try a))) + (\ try.monad map product.right (parser environment))) diff --git a/stdlib/source/library/lux/control/parser/json.lux b/stdlib/source/library/lux/control/parser/json.lux new file mode 100644 index 000000000..12fb90dd3 --- /dev/null +++ b/stdlib/source/library/lux/control/parser/json.lux @@ -0,0 +1,207 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." bit] + ["." text ("#\." equivalence monoid)] + [collection + ["." list ("#\." functor)] + ["." row] + ["." dictionary (#+ Dictionary)]] + [format + ["/" json (#+ JSON)]]] + [macro + ["." code]] + [math + [number + ["." frac]]]]] + ["." // ("#\." functor)]) + +(type: #export (Parser a) + {#.doc "JSON parser."} + (//.Parser (List JSON) a)) + +(exception: #export (unconsumed_input {input (List JSON)}) + (exception.report + ["Input" (exception.enumerate /.format input)])) + +(exception: #export empty_input) + +(def: #export (run parser json) + (All [a] (-> (Parser a) JSON (Try a))) + (case (//.run parser (list json)) + (#try.Success [remainder output]) + (case remainder + #.Nil + (#try.Success output) + + _ + (exception.throw ..unconsumed_input remainder)) + + (#try.Failure error) + (#try.Failure error))) + +(def: #export any + {#.doc "Just returns the JSON input without applying any logic."} + (Parser JSON) + (<| (function (_ inputs)) + (case inputs + #.Nil + (exception.throw ..empty_input []) + + (#.Cons head tail) + (#try.Success [tail head])))) + +(exception: #export (unexpected_value {value JSON}) + (exception.report + ["Value" (/.format value)])) + +(template [<name> <type> <tag> <desc>] + [(def: #export <name> + {#.doc (code.text ($_ text\compose "Reads a JSON value as " <desc> "."))} + (Parser <type>) + (do //.monad + [head ..any] + (case head + (<tag> value) + (wrap value) + + _ + (//.fail (exception.construct ..unexpected_value [head])))))] + + [null /.Null #/.Null "null"] + [boolean /.Boolean #/.Boolean "boolean"] + [number /.Number #/.Number "number"] + [string /.String #/.String "string"] + ) + +(exception: #export [a] (value_mismatch {reference JSON} {sample JSON}) + (exception.report + ["Reference" (/.format reference)] + ["Sample" (/.format sample)])) + +(template [<test> <check> <type> <equivalence> <tag> <desc>] + [(def: #export (<test> test) + {#.doc (code.text ($_ text\compose "Asks whether a JSON value is a " <desc> "."))} + (-> <type> (Parser Bit)) + (do //.monad + [head ..any] + (case head + (<tag> value) + (wrap (\ <equivalence> = test value)) + + _ + (//.fail (exception.construct ..unexpected_value [head]))))) + + (def: #export (<check> test) + {#.doc (code.text ($_ text\compose "Ensures a JSON value is a " <desc> "."))} + (-> <type> (Parser Any)) + (do //.monad + [head ..any] + (case head + (<tag> value) + (if (\ <equivalence> = test value) + (wrap []) + (//.fail (exception.construct ..value_mismatch [(<tag> test) (<tag> value)]))) + + _ + (//.fail (exception.construct ..unexpected_value [head])))))] + + [boolean? boolean! /.Boolean bit.equivalence #/.Boolean "boolean"] + [number? number! /.Number frac.equivalence #/.Number "number"] + [string? string! /.String text.equivalence #/.String "string"] + ) + +(def: #export (nullable parser) + (All [a] (-> (Parser a) (Parser (Maybe a)))) + (//.or ..null + parser)) + +(def: #export (array parser) + {#.doc "Parses a JSON array."} + (All [a] (-> (Parser a) (Parser a))) + (do //.monad + [head ..any] + (case head + (#/.Array values) + (case (//.run parser (row.to_list values)) + (#try.Failure error) + (//.fail error) + + (#try.Success [remainder output]) + (case remainder + #.Nil + (wrap output) + + _ + (//.fail (exception.construct ..unconsumed_input remainder)))) + + _ + (//.fail (exception.construct ..unexpected_value [head]))))) + +(def: #export (object parser) + {#.doc "Parses a JSON object. Use this with the 'field' combinator."} + (All [a] (-> (Parser a) (Parser a))) + (do //.monad + [head ..any] + (case head + (#/.Object kvs) + (case (|> kvs + dictionary.entries + (list\map (function (_ [key value]) + (list (#/.String key) value))) + list.concat + (//.run parser)) + (#try.Failure error) + (//.fail error) + + (#try.Success [remainder output]) + (case remainder + #.Nil + (wrap output) + + _ + (//.fail (exception.construct ..unconsumed_input remainder)))) + + _ + (//.fail (exception.construct ..unexpected_value [head]))))) + +(def: #export (field field_name parser) + {#.doc "Parses a field inside a JSON object. Use this inside the 'object' combinator."} + (All [a] (-> Text (Parser a) (Parser a))) + (function (recur inputs) + (case inputs + (^ (list& (#/.String key) value inputs')) + (if (text\= key field_name) + (case (//.run parser (list value)) + (#try.Success [#.Nil output]) + (#try.Success [inputs' output]) + + (#try.Success [inputs'' _]) + (exception.throw ..unconsumed_input inputs'') + + (#try.Failure error) + (#try.Failure error)) + (do try.monad + [[inputs'' output] (recur inputs')] + (wrap [(list& (#/.String key) value inputs'') + output]))) + + #.Nil + (exception.throw ..empty_input []) + + _ + (exception.throw ..unconsumed_input inputs)))) + +(def: #export dictionary + {#.doc "Parses a dictionary-like JSON object."} + (All [a] (-> (Parser a) (Parser (Dictionary Text a)))) + (|>> (//.and ..string) + //.some + ..object + (//\map (dictionary.from_list text.hash)))) diff --git a/stdlib/source/library/lux/control/parser/synthesis.lux b/stdlib/source/library/lux/control/parser/synthesis.lux new file mode 100644 index 000000000..9c8f76143 --- /dev/null +++ b/stdlib/source/library/lux/control/parser/synthesis.lux @@ -0,0 +1,164 @@ +(.module: + [library + [lux (#- function loop i64) + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." bit] + ["." name] + ["." text + ["%" format (#+ format)]]] + [math + [number + ["n" nat] + ["." i64] + ["." frac]]] + [tool + [compiler + [reference (#+) + [variable (#+ Register)]] + [arity (#+ Arity)] + [language + [lux + [analysis (#+ Variant Tuple Environment)] + ["/" synthesis (#+ Synthesis Abstraction)]]]]]]] + ["." //]) + +## TODO: Use "type:" ASAP. +(def: Input + Type + (type (List Synthesis))) + +(exception: #export (cannot_parse {input ..Input}) + (exception.report + ["Input" (exception.enumerate /.%synthesis input)])) + +(exception: #export (unconsumed_input {input ..Input}) + (exception.report + ["Input" (exception.enumerate /.%synthesis input)])) + +(exception: #export (expected_empty_input {input ..Input}) + (exception.report + ["Input" (exception.enumerate /.%synthesis input)])) + +(exception: #export (wrong_arity {expected Arity} {actual Arity}) + (exception.report + ["Expected" (%.nat expected)] + ["Actual" (%.nat actual)])) + +(exception: #export empty_input) + +(type: #export Parser + (//.Parser ..Input)) + +(def: #export (run parser input) + (All [a] (-> (Parser a) ..Input (Try a))) + (case (parser input) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [#.Nil value]) + (#try.Success value) + + (#try.Success [unconsumed _]) + (exception.throw ..unconsumed_input unconsumed))) + +(def: #export any + (Parser Synthesis) + (.function (_ input) + (case input + #.Nil + (exception.throw ..empty_input []) + + (#.Cons [head tail]) + (#try.Success [tail head])))) + +(def: #export end! + {#.doc "Ensures there are no more inputs."} + (Parser Any) + (.function (_ tokens) + (case tokens + #.Nil (#try.Success [tokens []]) + _ (exception.throw ..expected_empty_input [tokens])))) + +(def: #export end? + {#.doc "Checks whether there are no more inputs."} + (Parser Bit) + (.function (_ tokens) + (#try.Success [tokens (case tokens + #.Nil true + _ false)]))) + +(template [<query> <assertion> <tag> <type> <eq>] + [(def: #export <query> + (Parser <type>) + (.function (_ input) + (case input + (^ (list& (<tag> x) input')) + (#try.Success [input' x]) + + _ + (exception.throw ..cannot_parse input)))) + + (def: #export (<assertion> expected) + (-> <type> (Parser Any)) + (.function (_ input) + (case input + (^ (list& (<tag> actual) input')) + (if (\ <eq> = expected actual) + (#try.Success [input' []]) + (exception.throw ..cannot_parse input)) + + _ + (exception.throw ..cannot_parse input))))] + + [bit bit! /.bit Bit bit.equivalence] + [i64 i64! /.i64 (I64 Any) i64.equivalence] + [f64 f64! /.f64 Frac frac.equivalence] + [text text! /.text Text text.equivalence] + [local local! /.variable/local Nat n.equivalence] + [foreign foreign! /.variable/foreign Nat n.equivalence] + [constant constant! /.constant Name name.equivalence] + ) + +(def: #export (tuple parser) + (All [a] (-> (Parser a) (Parser a))) + (.function (_ input) + (case input + (^ (list& (/.tuple head) tail)) + (do try.monad + [output (..run parser head)] + (#try.Success [tail output])) + + _ + (exception.throw ..cannot_parse input)))) + +(def: #export (function expected parser) + (All [a] (-> Arity (Parser a) (Parser [(Environment Synthesis) a]))) + (.function (_ input) + (case input + (^ (list& (/.function/abstraction [environment actual body]) tail)) + (if (n.= expected actual) + (do try.monad + [output (..run parser (list body))] + (#try.Success [tail [environment output]])) + (exception.throw ..wrong_arity [expected actual])) + + _ + (exception.throw ..cannot_parse input)))) + +(def: #export (loop init_parsers iteration_parser) + (All [a b] (-> (Parser a) (Parser b) (Parser [Register a b]))) + (.function (_ input) + (case input + (^ (list& (/.loop/scope [start inits iteration]) tail)) + (do try.monad + [inits (..run init_parsers inits) + iteration (..run iteration_parser (list iteration))] + (#try.Success [tail [start inits iteration]])) + + _ + (exception.throw ..cannot_parse input)))) diff --git a/stdlib/source/library/lux/control/parser/text.lux b/stdlib/source/library/lux/control/parser/text.lux new file mode 100644 index 000000000..cfd1ab891 --- /dev/null +++ b/stdlib/source/library/lux/control/parser/text.lux @@ -0,0 +1,377 @@ +(.module: + [library + [lux (#- or and not) + [abstract + [monad (#+ Monad do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["/" text (#+ Char) ("#\." monoid)] + ["." product] + ["." maybe] + [collection + ["." list ("#\." fold)]]] + [macro + ["." code]] + [math + [number + ["n" nat ("#\." decimal)]]]]] + ["." //]) + +(type: #export Offset Nat) + +(def: start_offset Offset 0) + +(type: #export Parser + (//.Parser [Offset Text])) + +(type: #export Slice + {#basis Offset + #distance Offset}) + +(def: (remaining offset tape) + (-> Offset Text Text) + (|> tape (/.split offset) maybe.assume product.right)) + +(exception: #export (unconsumed_input {offset Offset} {tape Text}) + (exception.report + ["Offset" (n\encode offset)] + ["Input size" (n\encode (/.size tape))] + ["Remaining input" (remaining offset tape)])) + +(exception: #export (expected_to_fail {offset Offset} {tape Text}) + (exception.report + ["Offset" (n\encode offset)] + ["Input" (remaining offset tape)])) + +(exception: #export cannot_parse) +(exception: #export cannot_slice) + +(def: #export (run parser input) + (All [a] (-> (Parser a) Text (Try a))) + (case (parser [start_offset input]) + (#try.Failure msg) + (#try.Failure msg) + + (#try.Success [[end_offset _] output]) + (if (n.= end_offset (/.size input)) + (#try.Success output) + (exception.throw ..unconsumed_input [end_offset input])))) + +(def: #export offset + (Parser Offset) + (function (_ (^@ input [offset tape])) + (#try.Success [input offset]))) + +(def: (with_slices parser) + (-> (Parser (List Slice)) (Parser Slice)) + (do //.monad + [offset ..offset + slices parser] + (wrap (list\fold (function (_ [slice::basis slice::distance] + [total::basis total::distance]) + [total::basis ("lux i64 +" slice::distance total::distance)]) + {#basis offset + #distance 0} + slices)))) + +(def: #export any + {#.doc "Just returns the next character without applying any logic."} + (Parser Text) + (function (_ [offset tape]) + (case (/.nth offset tape) + (#.Some output) + (#try.Success [[("lux i64 +" 1 offset) tape] (/.from_code output)]) + + _ + (exception.throw ..cannot_parse [])))) + +(def: #export any! + {#.doc "Just returns the next character without applying any logic."} + (Parser Slice) + (function (_ [offset tape]) + (case (/.nth offset tape) + (#.Some _) + (#try.Success [[("lux i64 +" 1 offset) tape] + {#basis offset + #distance 1}]) + + _ + (exception.throw ..cannot_slice [])))) + +(template [<name> <type> <any>] + [(def: #export (<name> p) + {#.doc "Produce a character if the parser fails."} + (All [a] (-> (Parser a) (Parser <type>))) + (function (_ input) + (case (p input) + (#try.Failure msg) + (<any> input) + + _ + (exception.throw ..expected_to_fail input))))] + + [not Text ..any] + [not! Slice ..any!] + ) + +(exception: #export (cannot_match {reference Text}) + (exception.report + ["Reference" (/.format reference)])) + +(def: #export (this reference) + {#.doc "Lex a text if it matches the given sample."} + (-> Text (Parser Any)) + (function (_ [offset tape]) + (case (/.index_of' reference offset tape) + (#.Some where) + (if (n.= offset where) + (#try.Success [[("lux i64 +" (/.size reference) offset) tape] + []]) + (exception.throw ..cannot_match [reference])) + + _ + (exception.throw ..cannot_match [reference])))) + +(def: #export end! + {#.doc "Ensure the parser's input is empty."} + (Parser Any) + (function (_ (^@ input [offset tape])) + (if (n.= offset (/.size tape)) + (#try.Success [input []]) + (exception.throw ..unconsumed_input input)))) + +(def: #export peek + {#.doc "Lex the next character (without consuming it from the input)."} + (Parser Text) + (function (_ (^@ input [offset tape])) + (case (/.nth offset tape) + (#.Some output) + (#try.Success [input (/.from_code output)]) + + _ + (exception.throw ..cannot_parse [])))) + +(def: #export get_input + {#.doc "Get all of the remaining input (without consuming it)."} + (Parser Text) + (function (_ (^@ input [offset tape])) + (#try.Success [input (remaining offset tape)]))) + +(def: #export (range bottom top) + {#.doc "Only lex characters within a range."} + (-> Nat Nat (Parser Text)) + (do //.monad + [char any + #let [char' (maybe.assume (/.nth 0 char))] + _ (//.assert ($_ /\compose "Character is not within range: " (/.from_code bottom) "-" (/.from_code top)) + (.and (n.>= bottom char') + (n.<= top char')))] + (wrap char))) + +(template [<name> <bottom> <top> <desc>] + [(def: #export <name> + {#.doc (code.text ($_ /\compose "Only lex " <desc> " characters."))} + (Parser Text) + (..range (char <bottom>) (char <top>)))] + + [upper "A" "Z" "uppercase"] + [lower "a" "z" "lowercase"] + [decimal "0" "9" "decimal"] + [octal "0" "7" "octal"] + ) + +(def: #export alpha + {#.doc "Only lex alphabetic characters."} + (Parser Text) + (//.either lower upper)) + +(def: #export alpha_num + {#.doc "Only lex alphanumeric characters."} + (Parser Text) + (//.either alpha decimal)) + +(def: #export hexadecimal + {#.doc "Only lex hexadecimal digits."} + (Parser Text) + ($_ //.either + decimal + (range (char "a") (char "f")) + (range (char "A") (char "F")))) + +(template [<name>] + [(exception: #export (<name> {options Text} {character Char}) + (exception.report + ["Options" (/.format options)] + ["Character" (/.format (/.from_code character))]))] + + [character_should_be] + [character_should_not_be] + ) + +(template [<name> <modifier> <exception> <description_modifier>] + [(def: #export (<name> options) + {#.doc (code.text ($_ /\compose "Only lex characters that are" <description_modifier> " part of a piece of text."))} + (-> Text (Parser Text)) + (function (_ [offset tape]) + (case (/.nth offset tape) + (#.Some output) + (let [output' (/.from_code output)] + (if (<modifier> (/.contains? output' options)) + (#try.Success [[("lux i64 +" 1 offset) tape] output']) + (exception.throw <exception> [options output]))) + + _ + (exception.throw ..cannot_parse []))))] + + [one_of |> ..character_should_be ""] + [none_of .not ..character_should_not_be " not"] + ) + +(template [<name> <modifier> <exception> <description_modifier>] + [(def: #export (<name> options) + {#.doc (code.text ($_ /\compose "Only lex characters that are" <description_modifier> " part of a piece of text."))} + (-> Text (Parser Slice)) + (function (_ [offset tape]) + (case (/.nth offset tape) + (#.Some output) + (let [output' (/.from_code output)] + (if (<modifier> (/.contains? output' options)) + (#try.Success [[("lux i64 +" 1 offset) tape] + {#basis offset + #distance 1}]) + (exception.throw <exception> [options output]))) + + _ + (exception.throw ..cannot_slice []))))] + + [one_of! |> ..character_should_be ""] + [none_of! .not ..character_should_not_be " not"] + ) + +(exception: #export (character_does_not_satisfy_predicate {character Char}) + (exception.report + ["Character" (/.format (/.from_code character))])) + +(def: #export (satisfies p) + {#.doc "Only lex characters that satisfy a predicate."} + (-> (-> Char Bit) (Parser Text)) + (function (_ [offset tape]) + (case (/.nth offset tape) + (#.Some output) + (if (p output) + (#try.Success [[("lux i64 +" 1 offset) tape] (/.from_code output)]) + (exception.throw ..character_does_not_satisfy_predicate [output])) + + _ + (exception.throw ..cannot_parse [])))) + +(def: #export space + {#.doc "Only lex white-space."} + (Parser Text) + (..satisfies /.space?)) + +(def: #export (and left right) + (-> (Parser Text) (Parser Text) (Parser Text)) + (do //.monad + [=left left + =right right] + (wrap ($_ /\compose =left =right)))) + +(def: #export (and! left right) + (-> (Parser Slice) (Parser Slice) (Parser Slice)) + (do //.monad + [[left::basis left::distance] left + [right::basis right::distance] right] + (wrap [left::basis ("lux i64 +" left::distance right::distance)]))) + +(template [<name> <base> <doc_modifier>] + [(def: #export (<name> parser) + {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " characters as a single continuous text."))} + (-> (Parser Text) (Parser Text)) + (|> parser <base> (\ //.monad map /.concat)))] + + [some //.some "some"] + [many //.many "many"] + ) + +(template [<name> <base> <doc_modifier>] + [(def: #export (<name> parser) + {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " characters as a single continuous text."))} + (-> (Parser Slice) (Parser Slice)) + (with_slices (<base> parser)))] + + [some! //.some "some"] + [many! //.many "many"] + ) + +(template [<name> <base> <doc_modifier>] + [(def: #export (<name> amount parser) + {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " N characters."))} + (-> Nat (Parser Text) (Parser Text)) + (|> parser (<base> amount) (\ //.monad map /.concat)))] + + [exactly //.exactly "exactly"] + [at_most //.at_most "at most"] + [at_least //.at_least "at least"] + ) + +(template [<name> <base> <doc_modifier>] + [(def: #export (<name> amount parser) + {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " N characters."))} + (-> Nat (Parser Slice) (Parser Slice)) + (with_slices (<base> amount parser)))] + + [exactly! //.exactly "exactly"] + [at_most! //.at_most "at most"] + [at_least! //.at_least "at least"] + ) + +(def: #export (between from to parser) + {#.doc "Lex between N and M characters."} + (-> Nat Nat (Parser Text) (Parser Text)) + (|> parser (//.between from to) (\ //.monad map /.concat))) + +(def: #export (between! from to parser) + {#.doc "Lex between N and M characters."} + (-> Nat Nat (Parser Slice) (Parser Slice)) + (with_slices (//.between from to parser))) + +(def: #export (enclosed [start end] parser) + (All [a] (-> [Text Text] (Parser a) (Parser a))) + (|> parser + (//.before (this end)) + (//.after (this start)))) + +(def: #export (local local_input parser) + {#.doc "Run a parser with the given input, instead of the real one."} + (All [a] (-> Text (Parser a) (Parser a))) + (function (_ real_input) + (case (..run parser local_input) + (#try.Failure error) + (#try.Failure error) + + (#try.Success value) + (#try.Success [real_input value])))) + +(def: #export (slice parser) + (-> (Parser Slice) (Parser Text)) + (do //.monad + [[basis distance] parser] + (function (_ (^@ input [offset tape])) + (case (/.clip basis distance tape) + (#.Some output) + (#try.Success [input output]) + + #.None + (exception.throw ..cannot_slice []))))) + +(def: #export (embed structured text) + (All [s a] + (-> (Parser a) + (//.Parser s Text) + (//.Parser s a))) + (do //.monad + [raw text] + (//.lift (..run structured raw)))) diff --git a/stdlib/source/library/lux/control/parser/tree.lux b/stdlib/source/library/lux/control/parser/tree.lux new file mode 100644 index 000000000..5834c69e8 --- /dev/null +++ b/stdlib/source/library/lux/control/parser/tree.lux @@ -0,0 +1,60 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + [collection + [tree (#+ Tree) + ["." zipper (#+ Zipper)]]]]]] + ["." //]) + +(type: #export (Parser t a) + (//.Parser (Zipper t) a)) + +(def: #export (run' parser zipper) + (All [t a] (-> (Parser t a) (Zipper t) (Try a))) + (do try.monad + [[zipper output] (//.run parser zipper)] + (wrap output))) + +(def: #export (run parser tree) + (All [t a] (-> (Parser t a) (Tree t) (Try a))) + (run' parser (zipper.zip tree))) + +(def: #export value + (All [t] (Parser t t)) + (function (_ zipper) + (#try.Success [zipper (zipper.value zipper)]))) + +(exception: #export cannot-move-further) + +(template [<name> <direction>] + [(def: #export <name> + (All [t] (Parser t [])) + (function (_ zipper) + (case (<direction> zipper) + #.None + (exception.throw ..cannot-move-further []) + + (#.Some next) + (#try.Success [next []]))))] + + [down zipper.down] + [up zipper.up] + + [right zipper.right] + [rightmost zipper.rightmost] + + [left zipper.left] + [leftmost zipper.leftmost] + + [next zipper.next] + [end zipper.end] + + [previous zipper.previous] + [start zipper.start] + ) diff --git a/stdlib/source/library/lux/control/parser/type.lux b/stdlib/source/library/lux/control/parser/type.lux new file mode 100644 index 000000000..1e2c037d5 --- /dev/null +++ b/stdlib/source/library/lux/control/parser/type.lux @@ -0,0 +1,349 @@ +(.module: + [library + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["." function]] + [data + ["." text ("#\." monoid) + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)] + ["." dictionary (#+ Dictionary)]]] + [macro + ["." code]] + [math + [number + ["n" nat ("#\." decimal)]]] + ["." type ("#\." equivalence) + ["." check]]]] + ["." //]) + +(template [<name>] + [(exception: #export (<name> {type Type}) + (exception.report + ["Type" (%.type type)]))] + + [not_existential] + [not_recursive] + [not_named] + [not_parameter] + [unknown_parameter] + [not_function] + [not_application] + [not_polymorphic] + [not_variant] + [not_tuple] + ) + +(template [<name>] + [(exception: #export (<name> {expected Type} {actual Type}) + (exception.report + ["Expected" (%.type expected)] + ["Actual" (%.type actual)]))] + + [types_do_not_match] + [wrong_parameter] + ) + +(exception: #export empty_input) + +(exception: #export (unconsumed_input {remaining (List Type)}) + (exception.report + ["Types" (|> remaining + (list\map (|>> %.type (format text.new_line "* "))) + (text.join_with ""))])) + +(type: #export Env + (Dictionary Nat [Type Code])) + +(type: #export (Parser a) + (//.Parser [Env (List Type)] a)) + +(def: #export fresh + Env + (dictionary.new n.hash)) + +(def: (run' env poly types) + (All [a] (-> Env (Parser a) (List Type) (Try a))) + (case (//.run poly [env types]) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [[env' remaining] output]) + (case remaining + #.Nil + (#try.Success output) + + _ + (exception.throw ..unconsumed_input remaining)))) + +(def: #export (run poly type) + (All [a] (-> (Parser a) Type (Try a))) + (run' ..fresh poly (list type))) + +(def: #export env + (Parser Env) + (.function (_ [env inputs]) + (#try.Success [[env inputs] env]))) + +(def: (with_env temp poly) + (All [a] (-> Env (Parser a) (Parser a))) + (.function (_ [env inputs]) + (case (//.run poly [temp inputs]) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [[_ remaining] output]) + (#try.Success [[env remaining] output])))) + +(def: #export peek + (Parser Type) + (.function (_ [env inputs]) + (case inputs + #.Nil + (exception.throw ..empty_input []) + + (#.Cons headT tail) + (#try.Success [[env inputs] headT])))) + +(def: #export any + (Parser Type) + (.function (_ [env inputs]) + (case inputs + #.Nil + (exception.throw ..empty_input []) + + (#.Cons headT tail) + (#try.Success [[env tail] headT])))) + +(def: #export (local types poly) + (All [a] (-> (List Type) (Parser a) (Parser a))) + (.function (_ [env pass_through]) + (case (run' env poly types) + (#try.Failure error) + (#try.Failure error) + + (#try.Success output) + (#try.Success [[env pass_through] output])))) + +(def: (label idx) + (-> Nat Code) + (code.local_identifier ($_ text\compose "label" text.tab (n\encode idx)))) + +(def: #export (with_extension type poly) + (All [a] (-> Type (Parser a) (Parser [Code a]))) + (.function (_ [env inputs]) + (let [current_id (dictionary.size env) + g!var (label current_id)] + (case (//.run poly + [(dictionary.put current_id [type g!var] env) + inputs]) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [[_ inputs'] output]) + (#try.Success [[env inputs'] [g!var output]]))))) + +(template [<name> <flattener> <tag> <exception>] + [(def: #export (<name> poly) + (All [a] (-> (Parser a) (Parser a))) + (do //.monad + [headT ..any] + (let [members (<flattener> (type.un_name headT))] + (if (n.> 1 (list.size members)) + (local members poly) + (//.fail (exception.construct <exception> headT))))))] + + [variant type.flatten_variant #.Sum ..not_variant] + [tuple type.flatten_tuple #.Product ..not_tuple] + ) + +(def: polymorphic' + (Parser [Nat Type]) + (do //.monad + [headT any + #let [[num_arg bodyT] (type.flatten_univ_q (type.un_name headT))]] + (if (n.= 0 num_arg) + (//.fail (exception.construct ..not_polymorphic headT)) + (wrap [num_arg bodyT])))) + +(def: #export (polymorphic poly) + (All [a] (-> (Parser a) (Parser [Code (List Code) a]))) + (do {! //.monad} + [headT any + funcI (\ ! map dictionary.size ..env) + [num_args non_poly] (local (list headT) ..polymorphic') + env ..env + #let [funcL (label funcI) + [all_varsL env'] (loop [current_arg 0 + env' env + all_varsL (: (List Code) (list))] + (if (n.< num_args current_arg) + (if (n.= 0 current_arg) + (let [varL (label (inc funcI))] + (recur (inc current_arg) + (|> env' + (dictionary.put funcI [headT funcL]) + (dictionary.put (inc funcI) [(#.Parameter (inc funcI)) varL])) + (#.Cons varL all_varsL))) + (let [partialI (|> current_arg (n.* 2) (n.+ funcI)) + partial_varI (inc partialI) + partial_varL (label partial_varI) + partialC (` ((~ funcL) (~+ (|> (list.indices num_args) + (list\map (|>> (n.* 2) inc (n.+ funcI) label)) + list.reverse))))] + (recur (inc current_arg) + (|> env' + (dictionary.put partialI [.Nothing partialC]) + (dictionary.put partial_varI [(#.Parameter partial_varI) partial_varL])) + (#.Cons partial_varL all_varsL)))) + [all_varsL env']))]] + (<| (with_env env') + (local (list non_poly)) + (do ! + [output poly] + (wrap [funcL all_varsL output]))))) + +(def: #export (function in_poly out_poly) + (All [i o] (-> (Parser i) (Parser o) (Parser [i o]))) + (do //.monad + [headT any + #let [[inputsT outputT] (type.flatten_function (type.un_name headT))]] + (if (n.> 0 (list.size inputsT)) + (//.and (local inputsT in_poly) + (local (list outputT) out_poly)) + (//.fail (exception.construct ..not_function headT))))) + +(def: #export (apply poly) + (All [a] (-> (Parser a) (Parser a))) + (do //.monad + [headT any + #let [[funcT paramsT] (type.flatten_application (type.un_name headT))]] + (if (n.= 0 (list.size paramsT)) + (//.fail (exception.construct ..not_application headT)) + (..local (#.Cons funcT paramsT) poly)))) + +(template [<name> <test>] + [(def: #export (<name> expected) + (-> Type (Parser Any)) + (do //.monad + [actual any] + (if (<test> expected actual) + (wrap []) + (//.fail (exception.construct ..types_do_not_match [expected actual])))))] + + [exactly type\=] + [sub check.checks?] + [super (function.flip check.checks?)] + ) + +(def: #export (adjusted_idx env idx) + (-> Env Nat Nat) + (let [env_level (n./ 2 (dictionary.size env)) + parameter_level (n./ 2 idx) + parameter_idx (n.% 2 idx)] + (|> env_level dec (n.- parameter_level) (n.* 2) (n.+ parameter_idx)))) + +(def: #export parameter + (Parser Code) + (do //.monad + [env ..env + headT any] + (case headT + (#.Parameter idx) + (case (dictionary.get (adjusted_idx env idx) env) + (#.Some [poly_type poly_code]) + (wrap poly_code) + + #.None + (//.fail (exception.construct ..unknown_parameter headT))) + + _ + (//.fail (exception.construct ..not_parameter headT))))) + +(def: #export (parameter! id) + (-> Nat (Parser Any)) + (do //.monad + [env ..env + headT any] + (case headT + (#.Parameter idx) + (if (n.= id (adjusted_idx env idx)) + (wrap []) + (//.fail (exception.construct ..wrong_parameter [(#.Parameter id) headT]))) + + _ + (//.fail (exception.construct ..not_parameter headT))))) + +(def: #export existential + (Parser Nat) + (do //.monad + [headT any] + (case headT + (#.Ex ex_id) + (wrap ex_id) + + _ + (//.fail (exception.construct ..not_existential headT))))) + +(def: #export named + (Parser [Name Type]) + (do //.monad + [inputT any] + (case inputT + (#.Named name anonymousT) + (wrap [name anonymousT]) + + _ + (//.fail (exception.construct ..not_named inputT))))) + +(`` (template: (|nothing|) + (#.Named [(~~ (static .prelude_module)) "Nothing"] + (#.UnivQ #.Nil + (#.Parameter 1))))) + +(def: #export (recursive poly) + (All [a] (-> (Parser a) (Parser [Code a]))) + (do {! //.monad} + [headT any] + (case (type.un_name headT) + (^ (#.Apply (|nothing|) (#.UnivQ _ headT'))) + (do ! + [[recT _ output] (|> poly + (with_extension .Nothing) + (with_extension headT) + (local (list headT')))] + (wrap [recT output])) + + _ + (//.fail (exception.construct ..not_recursive headT))))) + +(def: #export recursive_self + (Parser Code) + (do //.monad + [env ..env + headT any] + (case (type.un_name headT) + (^multi (^ (#.Apply (|nothing|) (#.Parameter funcT_idx))) + (n.= 0 (adjusted_idx env funcT_idx)) + [(dictionary.get 0 env) (#.Some [self_type self_call])]) + (wrap self_call) + + _ + (//.fail (exception.construct ..not_recursive headT))))) + +(def: #export recursive_call + (Parser Code) + (do {! //.monad} + [env ..env + [funcT argsT] (..apply (//.and any (//.many any))) + _ (local (list funcT) (..parameter! 0)) + allC (let [allT (list& funcT argsT)] + (|> allT + (monad.map ! (function.constant ..parameter)) + (local allT)))] + (wrap (` ((~+ allC)))))) diff --git a/stdlib/source/library/lux/control/parser/xml.lux b/stdlib/source/library/lux/control/parser/xml.lux new file mode 100644 index 000000000..3fed4030e --- /dev/null +++ b/stdlib/source/library/lux/control/parser/xml.lux @@ -0,0 +1,142 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try) ("#\." functor)] + ["." exception (#+ exception:)]] + [data + ["." name ("#\." equivalence codec)] + ["." text + ["%" format (#+ format)]] + [collection + ["." list] + ["." dictionary]] + [format + ["/" xml (#+ Attribute Attrs Tag XML)]]]]] + ["." //]) + +(type: #export (Parser a) + (//.Parser [Attrs (List XML)] a)) + +(exception: #export empty_input) +(exception: #export unexpected_input) + +(exception: #export (wrong_tag {expected Tag} {actual Tag}) + (exception.report + ["Expected" (%.text (/.tag expected))] + ["Actual" (%.text (/.tag actual))])) + +(exception: #export (unknown_attribute {expected Attribute} {available (List Attribute)}) + (exception.report + ["Expected" (%.text (/.attribute expected))] + ["Available" (exception.enumerate (|>> /.attribute %.text) available)])) + +(exception: #export (unconsumed_inputs {inputs (List XML)}) + (exception.report + ["Inputs" (exception.enumerate (\ /.codec encode) inputs)])) + +(def: (run' parser attrs documents) + (All [a] (-> (Parser a) Attrs (List XML) (Try a))) + (case (//.run parser [attrs documents]) + (#try.Success [[attrs' remaining] output]) + (if (list.empty? remaining) + (#try.Success output) + (exception.throw ..unconsumed_inputs remaining)) + + (#try.Failure error) + (#try.Failure error))) + +(def: #export (run parser documents) + (All [a] (-> (Parser a) (List XML) (Try a))) + (..run' parser /.attributes documents)) + +(def: #export text + (Parser Text) + (function (_ [attrs documents]) + (case documents + #.Nil + (exception.throw ..empty_input []) + + (#.Cons head tail) + (case head + (#/.Text value) + (#try.Success [[attrs tail] value]) + + (#/.Node _) + (exception.throw ..unexpected_input []))))) + +(def: #export tag + (Parser Tag) + (function (_ [attrs documents]) + (case documents + #.Nil + (exception.throw ..empty_input []) + + (#.Cons head _) + (case head + (#/.Text _) + (exception.throw ..unexpected_input []) + + (#/.Node tag _ _) + (#try.Success [[attrs documents] tag]))))) + +(def: #export (attribute name) + (-> Attribute (Parser Text)) + (function (_ [attrs documents]) + (case (dictionary.get name attrs) + #.None + (exception.throw ..unknown_attribute [name (dictionary.keys attrs)]) + + (#.Some value) + (#try.Success [[attrs documents] value])))) + +(def: #export (node expected parser) + (All [a] (-> Tag (Parser a) (Parser a))) + (function (_ [attrs documents]) + (case documents + #.Nil + (exception.throw ..empty_input []) + + (#.Cons head tail) + (case head + (#/.Text _) + (exception.throw ..unexpected_input []) + + (#/.Node actual attrs' children) + (if (name\= expected actual) + (|> children + (..run' parser attrs') + (try\map (|>> [[attrs tail]]))) + (exception.throw ..wrong_tag [expected actual])))))) + +(def: #export ignore + (Parser Any) + (function (_ [attrs documents]) + (case documents + #.Nil + (exception.throw ..empty_input []) + + (#.Cons head tail) + (#try.Success [[attrs tail] []])))) + +(exception: #export nowhere) + +(def: #export (somewhere parser) + (All [a] (-> (Parser a) (Parser a))) + (function (recur [attrs input]) + (case (//.run parser [attrs input]) + (#try.Success [[attrs remaining] output]) + (#try.Success [[attrs remaining] output]) + + (#try.Failure error) + (case input + #.Nil + (exception.throw ..nowhere []) + + (#.Cons head tail) + (do try.monad + [[[attrs tail'] output] (recur [attrs tail])] + (wrap [[attrs (#.Cons head tail')] + output])))))) diff --git a/stdlib/source/library/lux/control/pipe.lux b/stdlib/source/library/lux/control/pipe.lux new file mode 100644 index 000000000..cac70fe6b --- /dev/null +++ b/stdlib/source/library/lux/control/pipe.lux @@ -0,0 +1,161 @@ +(.module: {#.doc "Composable extensions to the piping macros (|> and <|) that enhance them with various abilities."} + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["e" try] + ["p" parser + ["s" code (#+ Parser)]]] + [data + ["." identity] + [collection + ["." list ("#\." fold monad)]]] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code]] + [math + [number + ["n" nat] + ["i" int]]]]]) + +(def: body^ + (Parser (List Code)) + (s.tuple (p.some s.any))) + +(syntax: #export (new> start + {body body^} + prev) + {#.doc (doc "Ignores the piped argument, and begins a new pipe." + (n.= 1 + (|> 20 + (n.* 3) + (n.+ 4) + (new> 0 [inc]))))} + (wrap (list (` (|> (~ start) (~+ body)))))) + +(syntax: #export (let> binding body prev) + {#.doc (doc "Gives a name to the piped-argument, within the given expression." + (n.= 10 + (|> 5 + (let> x (n.+ x x)))))} + (wrap (list (` (let [(~ binding) (~ prev)] + (~ body)))))) + +(def: _reverse_ + (Parser Any) + (function (_ tokens) + (#e.Success [(list.reverse tokens) []]))) + +(syntax: #export (cond> {_ _reverse_} + prev + {else body^} + {_ _reverse_} + {branches (p.some (p.and body^ body^))}) + {#.doc (doc "Branching for pipes." + "Both the tests and the bodies are piped-code, and must be given inside a tuple." + (|> +5 + (cond> [i.even?] [(i.* +2)] + [i.odd?] [(i.* +3)] + [(new> -1 [])])))} + (with_gensyms [g!temp] + (wrap (list (` (let [(~ g!temp) (~ prev)] + (cond (~+ (do list.monad + [[test then] branches] + (list (` (|> (~ g!temp) (~+ test))) + (` (|> (~ g!temp) (~+ then)))))) + (|> (~ g!temp) (~+ else))))))))) + +(syntax: #export (if> {test body^} {then body^} {else body^} prev) + (wrap (list (` (cond> [(~+ test)] [(~+ then)] + [(~+ else)] + (~ prev)))))) + +(syntax: #export (when> {test body^} {then body^} prev) + (wrap (list (` (cond> [(~+ test)] [(~+ then)] + [] + (~ prev)))))) + +(syntax: #export (loop> {test body^} + {then body^} + prev) + {#.doc (doc "Loops for pipes." + "Both the testing and calculating steps are pipes and must be given inside tuples." + (|> +1 + (loop> [(i.< +10)] + [inc])))} + (with_gensyms [g!temp] + (wrap (list (` (loop [(~ g!temp) (~ prev)] + (if (|> (~ g!temp) (~+ test)) + ((~' recur) (|> (~ g!temp) (~+ then))) + (~ g!temp)))))))) + +(syntax: #export (do> monad + {steps (p.some body^)} + prev) + {#.doc (doc "Monadic pipes." + "Each steps in the monadic computation is a pipe and must be given inside a tuple." + (|> +5 + (do> identity.monad + [(i.* +3)] + [(i.+ +4)] + [inc])))} + (with_gensyms [g!temp] + (case (list.reverse steps) + (^ (list& last_step prev_steps)) + (let [step_bindings (do list.monad + [step (list.reverse prev_steps)] + (list g!temp (` (|> (~ g!temp) (~+ step)))))] + (wrap (list (` ((~! do) (~ monad) + [(~' #let) [(~ g!temp) (~ prev)] + (~+ step_bindings)] + (|> (~ g!temp) (~+ last_step))))))) + + _ + (wrap (list prev))))) + +(syntax: #export (exec> {body body^} + prev) + {#.doc (doc "Non-updating pipes." + "Will generate piped computations, but their results will not be used in the larger scope." + (|> +5 + (exec> [.nat %n log!]) + (i.* +10)))} + (with_gensyms [g!temp] + (wrap (list (` (let [(~ g!temp) (~ prev)] + (exec (|> (~ g!temp) (~+ body)) + (~ g!temp)))))))) + +(syntax: #export (tuple> {paths (p.many body^)} + prev) + {#.doc (doc "Parallel branching for pipes." + "Allows to run multiple pipelines for a value and gives you a tuple of the outputs." + (|> +5 + (tuple> [(i.* +10)] + [dec (i./ +2)] + [Int/encode])) + "Will become: [+50 +2 '+5']")} + (with_gensyms [g!temp] + (wrap (list (` (let [(~ g!temp) (~ prev)] + [(~+ (list\map (function (_ body) (` (|> (~ g!temp) (~+ body)))) + paths))])))))) + +(syntax: #export (case> {branches (p.many (p.and s.any s.any))} + prev) + {#.doc (doc "Pattern-matching for pipes." + "The bodies of each branch are NOT pipes; just regular values." + (|> +5 + (case> +0 "zero" + +1 "one" + +2 "two" + +3 "three" + +4 "four" + +5 "five" + +6 "six" + +7 "seven" + +8 "eight" + +9 "nine" + _ "???")))} + (wrap (list (` (case (~ prev) + (~+ (list\join (list\map (function (_ [pattern body]) (list pattern body)) + branches)))))))) diff --git a/stdlib/source/library/lux/control/reader.lux b/stdlib/source/library/lux/control/reader.lux new file mode 100644 index 000000000..95662b8ba --- /dev/null +++ b/stdlib/source/library/lux/control/reader.lux @@ -0,0 +1,72 @@ +(.module: + [library + [lux #* + [abstract + ["." functor (#+ Functor)] + [apply (#+ Apply)] + ["." monad (#+ Monad do)]]]]) + +(type: #export (Reader r a) + {#.doc "Computations that have access to some environmental value."} + (-> r a)) + +(def: #export ask + {#.doc "Get the environment."} + (All [r] (Reader r r)) + (function (_ env) env)) + +(def: #export (local change proc) + {#.doc "Run computation with a locally-modified environment."} + (All [r a] (-> (-> r r) (Reader r a) (Reader r a))) + (|>> change proc)) + +(def: #export (run env proc) + (All [r a] (-> r (Reader r a) a)) + (proc env)) + +(implementation: #export functor + (All [r] (Functor (Reader r))) + + (def: (map f fa) + (function (_ env) + (f (fa env))))) + +(implementation: #export apply + (All [r] (Apply (Reader r))) + + (def: &functor ..functor) + + (def: (apply ff fa) + (function (_ env) + ((ff env) (fa env))))) + +(implementation: #export monad + (All [r] (Monad (Reader r))) + + (def: &functor ..functor) + + (def: (wrap x) + (function (_ env) x)) + + (def: (join mma) + (function (_ env) + (mma env env)))) + +(implementation: #export (with monad) + {#.doc "Monad transformer for Reader."} + (All [M] (-> (Monad M) (All [e] (Monad (All [a] (Reader e (M a))))))) + + (def: &functor (functor.compose ..functor (get@ #monad.&functor monad))) + + (def: wrap (|>> (\ monad wrap) (\ ..monad wrap))) + + (def: (join eMeMa) + (function (_ env) + (do monad + [eMa (run env eMeMa)] + (run env eMa))))) + +(def: #export lift + {#.doc "Lift monadic values to the Reader wrapper."} + (All [M e a] (-> (M a) (Reader e (M a)))) + (\ ..monad wrap)) diff --git a/stdlib/source/library/lux/control/region.lux b/stdlib/source/library/lux/control/region.lux new file mode 100644 index 000000000..ff6247418 --- /dev/null +++ b/stdlib/source/library/lux/control/region.lux @@ -0,0 +1,158 @@ +(.module: + [library + [lux #* + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + ["." monad (#+ Monad do)]] + [control + ["." try (#+ Try)]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." fold)]]]]] + [// + ["." exception (#+ Exception exception:)]]) + +(type: (Cleaner r !) + (-> r (! (Try Any)))) + +(type: #export (Region r ! a) + (-> [r (List (Cleaner r !))] + (! [(List (Cleaner r !)) + (Try a)]))) + +(def: separator + Text + (format text.new_line + "-----------------------------------------" text.new_line + "-----------------------------------------" text.new_line + "-----------------------------------------" text.new_line + text.new_line)) + +(exception: #export [a] (clean_up_error {error Text} + {output (Try a)}) + (format error + (case output + (#try.Success _) + "" + + (#try.Failure error|output) + (format separator + error|output)))) + +(def: (combine_outcomes clean_up output) + (All [a] (-> (Try Any) (Try a) (Try a))) + (case clean_up + (#try.Success _) + output + + (#try.Failure error) + (exception.throw ..clean_up_error [error output]))) + +(def: #export (run monad computation) + (All [! a] + (-> (Monad !) (All [r] (Region r ! a)) + (! (Try a)))) + (do {! monad} + [[cleaners output] (computation [[] (list)]) + results (monad.map ! (function (_ cleaner) (cleaner [])) + cleaners)] + (wrap (list\fold combine_outcomes output results)))) + +(def: #export (acquire monad cleaner value) + (All [! a] (-> (Monad !) (-> a (! (Try Any))) a + (All [r] (Region r ! a)))) + (function (_ [region cleaners]) + (\ monad wrap [(#.Cons (function (_ region) (cleaner value)) + cleaners) + (#try.Success value)]))) + +(implementation: #export (functor super) + (All [!] + (-> (Functor !) + (All [r] (Functor (Region r !))))) + + (def: (map f) + (function (_ fa) + (function (_ region+cleaners) + (\ super map + (function (_ [cleaners' temp]) + [cleaners' (case temp + (#try.Success value) + (#try.Success (f value)) + + (#try.Failure error) + (#try.Failure error))]) + (fa region+cleaners)))))) + +(implementation: #export (apply super) + (All [!] + (-> (Monad !) + (All [r] (Apply (Region r !))))) + + (def: &functor + (..functor (get@ #monad.&functor super))) + + (def: (apply ff fa) + (function (_ [region cleaners]) + (do super + [[cleaners ef] (ff [region cleaners]) + [cleaners ea] (fa [region cleaners])] + (case ef + (#try.Success f) + (case ea + (#try.Success a) + (wrap [cleaners (#try.Success (f a))]) + + (#try.Failure error) + (wrap [cleaners (#try.Failure error)])) + + (#try.Failure error) + (wrap [cleaners (#try.Failure error)])))))) + +(implementation: #export (monad super) + (All [!] + (-> (Monad !) + (All [r] (Monad (Region r !))))) + + (def: &functor + (..functor (get@ #monad.&functor super))) + + (def: (wrap value) + (function (_ [region cleaners]) + (\ super wrap [cleaners (#try.Success value)]))) + + (def: (join ffa) + (function (_ [region cleaners]) + (do super + [[cleaners efa] (ffa [region cleaners])] + (case efa + (#try.Success fa) + (fa [region cleaners]) + + (#try.Failure error) + (wrap [cleaners (#try.Failure error)])))))) + +(def: #export (fail monad error) + (All [! a] + (-> (Monad !) Text + (All [r] (Region r ! a)))) + (function (_ [region cleaners]) + (\ monad wrap [cleaners (#try.Failure error)]))) + +(def: #export (throw monad exception message) + (All [! e a] + (-> (Monad !) (Exception e) e + (All [r] (Region r ! a)))) + (fail monad (exception.construct exception message))) + +(def: #export (lift monad operation) + (All [! a] + (-> (Monad !) (! a) + (All [r] (Region r ! a)))) + (function (_ [region cleaners]) + (do monad + [output operation] + (wrap [cleaners (#try.Success output)])))) diff --git a/stdlib/source/library/lux/control/remember.lux b/stdlib/source/library/lux/control/remember.lux new file mode 100644 index 000000000..86f9cb7a1 --- /dev/null +++ b/stdlib/source/library/lux/control/remember.lux @@ -0,0 +1,74 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." io] + ["." try] + ["." exception (#+ exception:)] + ["<>" parser ("#\." functor) + ["<c>" code (#+ Parser)]]] + [data + ["." text + ["%" format (#+ format)]]] + [time + ["." instant] + ["." date (#+ Date) ("#\." order)]] + ["." meta] + [macro + ["." code] + [syntax (#+ syntax:)]]]]) + +(exception: #export (must_remember {deadline Date} {today Date} {message Text} {focus (Maybe Code)}) + (exception.report + ["Deadline" (%.date deadline)] + ["Today" (%.date today)] + ["Message" message] + ["Code" (case focus + (#.Some focus) + (%.code focus) + + #.None + "")])) + +(def: deadline + (Parser Date) + ($_ <>.either + (<>\map (|>> instant.from_millis instant.date) + <c>.int) + (do <>.monad + [raw <c>.text] + (case (\ date.codec decode raw) + (#try.Success date) + (wrap date) + + (#try.Failure message) + (<>.fail message))))) + +(syntax: #export (remember {deadline ..deadline} {message <c>.text} {focus (<>.maybe <c>.any)}) + (let [now (io.run instant.now) + today (instant.date now)] + (if (date\< deadline today) + (wrap (case focus + (#.Some focus) + (list focus) + + #.None + (list))) + (meta.fail (exception.construct ..must_remember [deadline today message focus]))))) + +(template [<name> <message>] + [(syntax: #export (<name> {deadline ..deadline} {message <c>.text} {focus (<>.maybe <c>.any)}) + (wrap (list (` (..remember (~ (code.text (%.date deadline))) + (~ (code.text (format <message> " " message))) + (~+ (case focus + (#.Some focus) + (list focus) + + #.None + (list))))))))] + + [to_do "TODO"] + [fix_me "FIXME"] + ) diff --git a/stdlib/source/library/lux/control/security/capability.lux b/stdlib/source/library/lux/control/security/capability.lux new file mode 100644 index 000000000..13ae40d15 --- /dev/null +++ b/stdlib/source/library/lux/control/security/capability.lux @@ -0,0 +1,71 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["<>" parser + ["<c>" code]] + ["." io (#+ IO)] + [concurrency + ["." promise (#+ Promise)]]] + [data + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)]]] + [type + abstract] + ["." meta] + ["." macro + ["." code] + [syntax (#+ syntax:) + ["|.|" export] + ["|.|" declaration] + ["|.|" annotations]]]]]) + +(abstract: #export (Capability brand input output) + (-> input output) + + {#.doc (doc "Represents the capability to perform an operation." + "This operation is assumed to have security implications.")} + + (def: forge + (All [brand input output] + (-> (-> input output) + (Capability brand input output))) + (|>> :abstraction)) + + (def: #export (use capability input) + (All [brand input output] + (-> (Capability brand input output) + input + output)) + ((:representation capability) input)) + + (syntax: #export (capability: {export |export|.parser} + {declaration |declaration|.parser} + {annotations (<>.maybe |annotations|.parser)} + {[forge input output] (<c>.form ($_ <>.and <c>.local_identifier <c>.any <c>.any))}) + (do {! meta.monad} + [this_module meta.current_module_name + #let [[name vars] declaration] + g!brand (\ ! map (|>> %.code code.text) + (macro.gensym (format (%.name [this_module name])))) + #let [capability (` (..Capability (.primitive (~ g!brand)) (~ input) (~ output)))]] + (wrap (list (` (type: (~+ (|export|.format export)) + (~ (|declaration|.format declaration)) + (~ capability))) + (` (def: (~ (code.local_identifier forge)) + (All [(~+ (list\map code.local_identifier vars))] + (-> (-> (~ input) (~ output)) + (~ capability))) + (~! ..forge))) + )))) + + (def: #export (async capability) + (All [brand input output] + (-> (Capability brand input (IO output)) + (Capability brand input (Promise output)))) + (..forge (|>> ((:representation capability)) promise.future))) + ) diff --git a/stdlib/source/library/lux/control/security/policy.lux b/stdlib/source/library/lux/control/security/policy.lux new file mode 100644 index 000000000..3c1eb579e --- /dev/null +++ b/stdlib/source/library/lux/control/security/policy.lux @@ -0,0 +1,93 @@ +(.module: + [library + [lux #* + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad)]] + [type + abstract]]]) + +(abstract: #export (Policy brand value label) + value + + (type: #export (Can_Upgrade brand label value) + {#.doc (doc "Represents the capacity to 'upgrade' a value.")} + (-> value (Policy brand value label))) + + (type: #export (Can_Downgrade brand label value) + {#.doc (doc "Represents the capacity to 'downgrade' a value.")} + (-> (Policy brand value label) value)) + + (type: #export (Privilege brand label) + {#.doc (doc "Represents the privilege to both 'upgrade' and 'downgrade' a value.")} + {#can_upgrade (Can_Upgrade brand label) + #can_downgrade (Can_Downgrade brand label)}) + + (def: privilege + Privilege + {#can_upgrade (|>> :abstraction) + #can_downgrade (|>> :representation)}) + + (type: #export (Delegation brand from to) + {#.doc (doc "Represents the act of delegating policy capacities.")} + (All [value] + (-> (Policy brand value from) + (Policy brand value to)))) + + (def: #export (delegation downgrade upgrade) + {#.doc (doc "Delegating policy capacities.")} + (All [brand from to] + (-> (Can_Downgrade brand from) (Can_Upgrade brand to) + (Delegation brand from to))) + (|>> downgrade upgrade)) + + (type: #export (Context brand scope label) + {#.doc (doc "A computational context with an associated policy privilege.")} + (-> (Privilege brand label) + (scope label))) + + (def: #export (with_policy context) + (All [brand scope] + (Ex [label] + (-> (Context brand scope label) + (scope label)))) + (context ..privilege)) + + (def: (decorate constructor) + (-> Type Type) + (type (All [brand label] (constructor (All [value] (Policy brand value label)))))) + + (implementation: #export functor + (:~ (decorate Functor)) + + (def: (map f fa) + (|> fa :representation f :abstraction))) + + (implementation: #export apply + (:~ (decorate Apply)) + + (def: &functor ..functor) + (def: (apply ff fa) + (:abstraction ((:representation ff) (:representation fa))))) + + (implementation: #export monad + (:~ (decorate Monad)) + + (def: &functor ..functor) + (def: wrap (|>> :abstraction)) + (def: join (|>> :representation))) + ) + +(template [<brand> <value> <upgrade> <downgrade>] + [(abstract: #export <brand> + Any + + (type: #export <value> (Policy <brand>)) + (type: #export <upgrade> (Can_Upgrade <brand>)) + (type: #export <downgrade> (Can_Downgrade <brand>)) + )] + + [Privacy Private Can_Conceal Can_Reveal] + [Safety Safe Can_Trust Can_Distrust] + ) diff --git a/stdlib/source/library/lux/control/state.lux b/stdlib/source/library/lux/control/state.lux new file mode 100644 index 000000000..ef0e2dbb7 --- /dev/null +++ b/stdlib/source/library/lux/control/state.lux @@ -0,0 +1,149 @@ +(.module: + [library + [lux #* + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)]]]]) + +(type: #export (State s a) + {#.doc "Stateful computations."} + (-> s [s a])) + +(def: #export get + {#.doc "Read the current state."} + (All [s] (State s s)) + (function (_ state) + [state state])) + +(def: #export (put new-state) + {#.doc "Set the new state."} + (All [s] (-> s (State s Any))) + (function (_ state) + [new-state []])) + +(def: #export (update change) + {#.doc "Compute the new state."} + (All [s] (-> (-> s s) (State s Any))) + (function (_ state) + [(change state) []])) + +(def: #export (use user) + {#.doc "Run function on current state."} + (All [s a] (-> (-> s a) (State s a))) + (function (_ state) + [state (user state)])) + +(def: #export (local change action) + {#.doc "Run computation with a locally-modified state."} + (All [s a] (-> (-> s s) (State s a) (State s a))) + (function (_ state) + (let [[state' output] (action (change state))] + [state output]))) + +(def: #export (run state action) + {#.doc "Run a stateful computation."} + (All [s a] (-> s (State s a) [s a])) + (action state)) + +(implementation: #export functor + (All [s] (Functor (State s))) + + (def: (map f ma) + (function (_ state) + (let [[state' a] (ma state)] + [state' (f a)])))) + +(implementation: #export apply + (All [s] (Apply (State s))) + + (def: &functor ..functor) + + (def: (apply ff fa) + (function (_ state) + (let [[state' f] (ff state) + [state'' a] (fa state')] + [state'' (f a)])))) + +(implementation: #export monad + (All [s] (Monad (State s))) + + (def: &functor ..functor) + + (def: (wrap a) + (function (_ state) + [state a])) + + (def: (join mma) + (function (_ state) + (let [[state' ma] (mma state)] + (ma state'))))) + +(def: #export (while condition body) + (All [s] (-> (State s Bit) (State s Any) (State s Any))) + (do {! ..monad} + [execute? condition] + (if execute? + (do ! + [_ body] + (while condition body)) + (wrap [])))) + +(def: #export (do-while condition body) + (All [s] (-> (State s Bit) (State s Any) (State s Any))) + (do ..monad + [_ body] + (while condition body))) + +(implementation: (with//functor functor) + (All [M s] (-> (Functor M) (Functor (All [a] (-> s (M [s a])))))) + + (def: (map f sfa) + (function (_ state) + (\ functor map (function (_ [s a]) [s (f a)]) + (sfa state))))) + +(implementation: (with//apply monad) + (All [M s] (-> (Monad M) (Apply (All [a] (-> s (M [s a])))))) + + (def: &functor (with//functor (\ monad &functor))) + + (def: (apply sFf sFa) + (function (_ state) + (do monad + [[state f] (sFf state) + [state a] (sFa state)] + (wrap [state (f a)]))))) + +(type: #export (State' M s a) + {#.doc "Stateful computations decorated by a monad."} + (-> s (M [s a]))) + +(def: #export (run' state action) + {#.doc "Run a stateful computation decorated by a monad."} + (All [M s a] (-> s (State' M s a) (M [s a]))) + (action state)) + +(implementation: #export (with monad) + {#.doc "A monad transformer to create composite stateful computations."} + (All [M s] (-> (Monad M) (Monad (State' M s)))) + + (def: &functor (with//functor (\ monad &functor))) + + (def: (wrap a) + (function (_ state) + (\ monad wrap [state a]))) + + (def: (join sMsMa) + (function (_ state) + (do monad + [[state' sMa] (sMsMa state)] + (sMa state'))))) + +(def: #export (lift monad ma) + {#.doc "Lift monadic values to the State' wrapper."} + (All [M s a] (-> (Monad M) (M a) (State' M s a))) + (function (_ state) + (do monad + [a ma] + (wrap [state a])))) diff --git a/stdlib/source/library/lux/control/thread.lux b/stdlib/source/library/lux/control/thread.lux new file mode 100644 index 000000000..818c38298 --- /dev/null +++ b/stdlib/source/library/lux/control/thread.lux @@ -0,0 +1,106 @@ +(.module: + [library + [lux #* + ["@" target] + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)]] + [control + ["." io (#+ IO)]] + [data + [collection + ["." array (#+ Array)]]] + [type + abstract]]]) + +(type: #export (Thread ! a) + (-> ! a)) + +(abstract: #export (Box t v) + (Array v) + + {#.doc "A mutable box holding a value."} + + (def: #export (box init) + (All [a] (-> a (All [!] (Thread ! (Box ! a))))) + (function (_ !) + (|> (array.new 1) + (array.write! 0 init) + :abstraction))) + + (def: #export (read box) + (All [! a] (-> (Box ! a) (Thread ! a))) + (function (_ !) + (for {@.old + ("jvm aaload" (:representation box) 0) + + @.jvm + ("jvm array read object" + (|> 0 + (:as (primitive "java.lang.Long")) + "jvm object cast" + "jvm conversion long-to-int") + (:representation box)) + + @.js ("js array read" 0 (:representation box)) + @.python ("python array read" 0 (:representation box)) + @.lua ("lua array read" 0 (:representation box)) + @.ruby ("ruby array read" 0 (:representation box)) + @.php ("php array read" 0 (:representation box)) + @.scheme ("scheme array read" 0 (:representation box))}))) + + (def: #export (write value box) + (All [a] (-> a (All [!] (-> (Box ! a) (Thread ! Any))))) + (function (_ !) + (|> box :representation (array.write! 0 value) :abstraction))) + ) + +(def: #export (run thread) + (All [a] + (-> (All [!] (Thread ! a)) + a)) + (thread [])) + +(def: #export io + (All [a] + (-> (All [!] (Thread ! a)) + (IO a))) + (|>> ..run io.io)) + +(implementation: #export functor + (All [!] (Functor (Thread !))) + + (def: (map f) + (function (_ fa) + (function (_ !) + (f (fa !)))))) + +(implementation: #export apply + (All [!] (Apply (Thread !))) + + (def: &functor ..functor) + + (def: (apply ff fa) + (function (_ !) + ((ff !) (fa !))))) + +(implementation: #export monad + (All [!] (Monad (Thread !))) + + (def: &functor ..functor) + + (def: (wrap value) + (function (_ !) + value)) + + (def: (join ffa) + (function (_ !) + ((ffa !) !)))) + +(def: #export (update f box) + (All [a] (-> (-> a a) (All [!] (-> (Box ! a) (Thread ! a))))) + (do ..monad + [old (read box) + _ (write (f old) box)] + (wrap old))) diff --git a/stdlib/source/library/lux/control/try.lux b/stdlib/source/library/lux/control/try.lux new file mode 100644 index 000000000..013553b04 --- /dev/null +++ b/stdlib/source/library/lux/control/try.lux @@ -0,0 +1,153 @@ +(.module: + [library + [lux #* + [abstract + [apply (#+ Apply)] + [equivalence (#+ Equivalence)] + ["." functor (#+ Functor)] + ["." monad (#+ Monad do)]] + [meta + ["." location]]]]) + +(type: #export (Try a) + (#Failure Text) + (#Success a)) + +(implementation: #export functor + (Functor Try) + + (def: (map f ma) + (case ma + (#Failure msg) + (#Failure msg) + + (#Success datum) + (#Success (f datum))))) + +(implementation: #export apply + (Apply Try) + + (def: &functor ..functor) + + (def: (apply ff fa) + (case ff + (#Success f) + (case fa + (#Success a) + (#Success (f a)) + + (#Failure msg) + (#Failure msg)) + + (#Failure msg) + (#Failure msg)) + )) + +(implementation: #export monad + (Monad Try) + + (def: &functor ..functor) + + (def: (wrap a) + (#Success a)) + + (def: (join mma) + (case mma + (#Failure msg) + (#Failure msg) + + (#Success ma) + ma))) + +(implementation: #export (with monad) + ## TODO: Replace (All [a] (M (Try a))) with (functor.Then M Try) + (All [M] (-> (Monad M) (Monad (All [a] (M (Try a)))))) + + (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor)) + + (def: wrap (|>> (\ ..monad wrap) (\ monad wrap))) + + (def: (join MeMea) + (do monad + [eMea MeMea] + (case eMea + (#Failure try) + (wrap (#Failure try)) + + (#Success Mea) + Mea)))) + +(def: #export (lift monad) + (All [M a] (-> (Monad M) (-> (M a) (M (Try a))))) + (\ monad map (\ ..monad wrap))) + +(implementation: #export (equivalence (^open "_\.")) + (All [a] (-> (Equivalence a) (Equivalence (Try a)))) + + (def: (= reference sample) + (case [reference sample] + [(#Success reference) (#Success sample)] + (_\= reference sample) + + [(#Failure reference) (#Failure sample)] + ("lux text =" reference sample) + + _ + false + ))) + +(def: #export (succeed value) + (All [a] (-> a (Try a))) + (#Success value)) + +(def: #export (fail message) + (-> Text Try) + (#Failure message)) + +(def: #export (assume try) + (All [a] (-> (Try a) a)) + (case try + (#Success value) + value + + (#Failure message) + (error! message))) + +(def: #export (to_maybe try) + (All [a] (-> (Try a) (Maybe a))) + (case try + (#Success value) + (#.Some value) + + (#Failure message) + #.None)) + +(def: #export (from_maybe maybe) + (All [a] (-> (Maybe a) (Try a))) + (case maybe + (#.Some value) + (#Success value) + + #.None + (#Failure (`` (("lux in-module" (~~ (static .prelude_module)) .name\encode) + (name_of ..from_maybe)))))) + +(macro: #export (default tokens compiler) + {#.doc (doc "Allows you to provide a default value that will be used" + "if a (Try x) value turns out to be #Failure." + "Note: the expression for the default value will not be computed if the base computation succeeds." + (= "bar" + (default "foo" (#..Success "bar"))) + (= "foo" + (default "foo" (#..Failure "KABOOM!"))))} + (case tokens + (^ (list else try)) + (#Success [compiler (list (` (case (~ try) + (#..Success (~' g!temp)) + (~' g!temp) + + (#..Failure (~ [location.dummy (#.Identifier ["" ""])])) + (~ else))))]) + + _ + (#Failure "Wrong syntax for default"))) diff --git a/stdlib/source/library/lux/control/writer.lux b/stdlib/source/library/lux/control/writer.lux new file mode 100644 index 000000000..2ddf343df --- /dev/null +++ b/stdlib/source/library/lux/control/writer.lux @@ -0,0 +1,78 @@ +(.module: + [library + [lux #* + ["@" target] + [abstract + monoid + [apply (#+ Apply)] + ["." functor (#+ Functor)] + ["." monad (#+ Monad do)]]]]) + +(type: #export (Writer l a) + {#.doc "Represents a value with an associated 'log' value to record arbitrary information."} + {#log l + #value a}) + +(def: #export (write l) + {#.doc "Set the log to a particular value."} + (All [l] (-> l (Writer l Any))) + [l []]) + +(implementation: #export functor + (All [l] + (Functor (Writer l))) + + (def: (map f fa) + (let [[log datum] fa] + [log (f datum)]))) + +(implementation: #export (apply monoid) + (All [l] + (-> (Monoid l) (Apply (Writer l)))) + + (def: &functor ..functor) + + (def: (apply ff fa) + (let [[log1 f] ff + [log2 a] fa] + [(\ monoid compose log1 log2) (f a)]))) + +(implementation: #export (monad monoid) + (All [l] + (-> (Monoid l) (Monad (Writer l)))) + + (def: &functor ..functor) + + (def: wrap + (|>> [(\ monoid identity)])) + + (def: (join mma) + (let [[log1 [log2 a]] mma] + [(\ monoid compose log1 log2) a]))) + +(implementation: #export (with monoid monad) + (All [l M] (-> (Monoid l) (Monad M) (Monad (All [a] (M (Writer l a)))))) + + (def: &functor + (functor.compose (get@ #monad.&functor monad) + ..functor)) + + (def: wrap + (let [writer (..monad monoid)] + (|>> (\ writer wrap) (\ monad wrap)))) + + (def: (join MlMla) + (do monad + [[l1 Mla] (for {@.old + (: (($ 1) (Writer ($ 0) (($ 1) (Writer ($ 0) ($ 2))))) + MlMla)} + ## On new compiler + MlMla) + [l2 a] Mla] + (wrap [(\ monoid compose l1 l2) a])))) + +(def: #export (lift monoid monad) + (All [l M a] + (-> (Monoid l) (Monad M) + (-> (M a) (M (Writer l a))))) + (\ monad map (|>> [(\ monoid identity)]))) diff --git a/stdlib/source/library/lux/data/binary.lux b/stdlib/source/library/lux/data/binary.lux new file mode 100644 index 000000000..11bc86754 --- /dev/null +++ b/stdlib/source/library/lux/data/binary.lux @@ -0,0 +1,367 @@ +(.module: + [library + [lux (#- i64) + ["@" target] + ["." ffi] + [abstract + [monad (#+ do)] + [equivalence (#+ Equivalence)] + [monoid (#+ Monoid)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." maybe] + [text + ["%" format (#+ format)]] + [collection + ["." array]]] + [math + [number (#+ hex) + ["n" nat] + ["f" frac] + ["." i64]]]]]) + +(exception: #export (index_out_of_bounds {size Nat} {index Nat}) + (exception.report + ["Size" (%.nat size)] + ["Index" (%.nat index)])) + +(exception: #export (slice_out_of_bounds {size Nat} {offset Nat} {length Nat}) + (exception.report + ["Size" (%.nat size)] + ["Offset" (%.nat offset)] + ["Length" (%.nat length)])) + +(with_expansions [<jvm> (as_is (type: #export Binary (ffi.type [byte])) + + (ffi.import: java/lang/Object) + + (ffi.import: java/lang/System + ["#::." + (#static arraycopy [java/lang/Object int java/lang/Object int int] #try void)]) + + (ffi.import: java/util/Arrays + ["#::." + (#static copyOfRange [[byte] int int] [byte]) + (#static equals [[byte] [byte]] boolean)]) + + (def: byte_mask + I64 + (|> i64.bits_per_byte i64.mask .i64)) + + (def: i64 + (-> (primitive "java.lang.Byte") I64) + (|>> ffi.byte_to_long (:as I64) (i64.and ..byte_mask))) + + (def: byte + (-> (I64 Any) (primitive "java.lang.Byte")) + (for {@.old + (|>> .int ffi.long_to_byte) + + @.jvm + (|>> .int (:as (primitive "java.lang.Long")) ffi.long_to_byte)})))] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>) + + @.js + (as_is (ffi.import: ArrayBuffer + ["#::." + (new [ffi.Number])]) + + (ffi.import: Uint8Array + ["#::." + (new [ArrayBuffer]) + (length ffi.Number)]) + + (type: #export Binary + Uint8Array)) + + @.python + (type: #export Binary + (primitive "bytearray")) + + @.scheme + (as_is (type: #export Binary + (primitive "bytevector")) + + (ffi.import: (make-bytevector [Nat] Binary)) + (ffi.import: (bytevector-u8-ref [Binary Nat] I64)) + (ffi.import: (bytevector-u8-set! [Binary Nat (I64 Any)] Any)) + (ffi.import: (bytevector-length [Binary] Nat)))} + + ## Default + (type: #export Binary + (array.Array (I64 Any))))) + +(template: (!size binary) + (for {@.old (ffi.array_length binary) + @.jvm (ffi.array_length binary) + + @.js + (|> binary + Uint8Array::length + f.nat) + + @.python + (|> binary + (:as (array.Array (I64 Any))) + "python array length") + + @.scheme + (..bytevector-length [binary])} + + ## Default + (array.size binary))) + +(template: (!read idx binary) + (for {@.old (..i64 (ffi.array_read idx binary)) + @.jvm (..i64 (ffi.array_read idx binary)) + + @.js + (|> binary + (: ..Binary) + (:as (array.Array .Frac)) + ("js array read" idx) + f.nat + .i64) + + @.python + (|> binary + (:as (array.Array .I64)) + ("python array read" idx)) + + @.scheme + (..bytevector-u8-ref [binary idx])} + + ## Default + (|> binary + (array.read idx) + (maybe.default (: (I64 Any) 0)) + (:as I64)))) + +(template: (!!write <byte_type> <post> <write> idx value binary) + (|> binary + (: ..Binary) + (:as (array.Array <byte_type>)) + (<write> idx (|> value .nat (n.% (hex "100")) <post>)) + (:as ..Binary))) + +(template: (!write idx value binary) + (for {@.old (ffi.array_write idx (..byte value) binary) + @.jvm (ffi.array_write idx (..byte value) binary) + + @.js (!!write .Frac n.frac "js array write" idx value binary) + @.python (!!write (I64 Any) (:as (I64 Any)) "python array write" idx value binary) + @.scheme (exec (..bytevector-u8-set! [binary idx value]) + binary)} + + ## Default + (array.write! idx (|> value .nat (n.% (hex "100"))) binary))) + +(def: #export size + (-> Binary Nat) + (|>> !size)) + +(def: #export create + (-> Nat Binary) + (for {@.old (|>> (ffi.array byte)) + @.jvm (|>> (ffi.array byte)) + + @.js + (|>> n.frac ArrayBuffer::new Uint8Array::new) + + @.python + (|>> ("python apply" (:as ffi.Function ("python constant" "bytearray"))) + (:as Binary)) + + @.scheme + (|>> ..make-bytevector)} + + ## Default + array.new)) + +(def: #export (fold f init binary) + (All [a] (-> (-> I64 a a) a Binary a)) + (let [size (..!size binary)] + (loop [idx 0 + output init] + (if (n.< size idx) + (recur (inc idx) (f (!read idx binary) output)) + output)))) + +(def: #export (read/8 idx binary) + (-> Nat Binary (Try I64)) + (if (n.< (..!size binary) idx) + (#try.Success (!read idx binary)) + (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) + +(def: #export (read/16 idx binary) + (-> Nat Binary (Try I64)) + (if (n.< (..!size binary) (n.+ 1 idx)) + (#try.Success ($_ i64.or + (i64.left_shift 8 (!read idx binary)) + (!read (n.+ 1 idx) binary))) + (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) + +(def: #export (read/32 idx binary) + (-> Nat Binary (Try I64)) + (if (n.< (..!size binary) (n.+ 3 idx)) + (#try.Success ($_ i64.or + (i64.left_shift 24 (!read idx binary)) + (i64.left_shift 16 (!read (n.+ 1 idx) binary)) + (i64.left_shift 8 (!read (n.+ 2 idx) binary)) + (!read (n.+ 3 idx) binary))) + (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) + +(def: #export (read/64 idx binary) + (-> Nat Binary (Try I64)) + (if (n.< (..!size binary) (n.+ 7 idx)) + (#try.Success ($_ i64.or + (i64.left_shift 56 (!read idx binary)) + (i64.left_shift 48 (!read (n.+ 1 idx) binary)) + (i64.left_shift 40 (!read (n.+ 2 idx) binary)) + (i64.left_shift 32 (!read (n.+ 3 idx) binary)) + (i64.left_shift 24 (!read (n.+ 4 idx) binary)) + (i64.left_shift 16 (!read (n.+ 5 idx) binary)) + (i64.left_shift 8 (!read (n.+ 6 idx) binary)) + (!read (n.+ 7 idx) binary))) + (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) + +(def: #export (write/8 idx value binary) + (-> Nat (I64 Any) Binary (Try Binary)) + (if (n.< (..!size binary) idx) + (#try.Success (|> binary + (!write idx value))) + (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) + +(def: #export (write/16 idx value binary) + (-> Nat (I64 Any) Binary (Try Binary)) + (if (n.< (..!size binary) (n.+ 1 idx)) + (#try.Success (|> binary + (!write idx (i64.right_shift 8 value)) + (!write (n.+ 1 idx) value))) + (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) + +(def: #export (write/32 idx value binary) + (-> Nat (I64 Any) Binary (Try Binary)) + (if (n.< (..!size binary) (n.+ 3 idx)) + (#try.Success (|> binary + (!write idx (i64.right_shift 24 value)) + (!write (n.+ 1 idx) (i64.right_shift 16 value)) + (!write (n.+ 2 idx) (i64.right_shift 8 value)) + (!write (n.+ 3 idx) value))) + (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) + +(def: #export (write/64 idx value binary) + (-> Nat (I64 Any) Binary (Try Binary)) + (if (n.< (..!size binary) (n.+ 7 idx)) + (for {@.scheme (let [write_high (|>> (!write idx (i64.right_shift 56 value)) + (!write (n.+ 1 idx) (i64.right_shift 48 value)) + (!write (n.+ 2 idx) (i64.right_shift 40 value)) + (!write (n.+ 3 idx) (i64.right_shift 32 value))) + write_low (|>> (!write (n.+ 4 idx) (i64.right_shift 24 value)) + (!write (n.+ 5 idx) (i64.right_shift 16 value)) + (!write (n.+ 6 idx) (i64.right_shift 8 value)) + (!write (n.+ 7 idx) value))] + (|> binary write_high write_low #try.Success))} + (#try.Success (|> binary + (!write idx (i64.right_shift 56 value)) + (!write (n.+ 1 idx) (i64.right_shift 48 value)) + (!write (n.+ 2 idx) (i64.right_shift 40 value)) + (!write (n.+ 3 idx) (i64.right_shift 32 value)) + (!write (n.+ 4 idx) (i64.right_shift 24 value)) + (!write (n.+ 5 idx) (i64.right_shift 16 value)) + (!write (n.+ 6 idx) (i64.right_shift 8 value)) + (!write (n.+ 7 idx) value)))) + (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) + +(implementation: #export equivalence + (Equivalence Binary) + + (def: (= reference sample) + (with_expansions [<jvm> (java/util/Arrays::equals reference sample)] + (for {@.old <jvm> + @.jvm <jvm>} + (let [limit (!size reference)] + (and (n.= limit + (!size sample)) + (loop [idx 0] + (if (n.< limit idx) + (and (n.= (!read idx reference) + (!read idx sample)) + (recur (inc idx))) + true)))))))) + +(for {@.old (as_is) + @.jvm (as_is)} + + ## Default + (exception: #export (cannot_copy_bytes {bytes Nat} + {source_input Nat} + {target_output Nat}) + (exception.report + ["Bytes" (%.nat bytes)] + ["Source input space" (%.nat source_input)] + ["Target output space" (%.nat target_output)]))) + +(def: #export (copy bytes source_offset source target_offset target) + (-> Nat Nat Binary Nat Binary (Try Binary)) + (with_expansions [<jvm> (as_is (do try.monad + [_ (java/lang/System::arraycopy source (.int source_offset) target (.int target_offset) (.int bytes))] + (wrap target)))] + (for {@.old <jvm> + @.jvm <jvm>} + + ## Default + (let [source_input (n.- source_offset (!size source)) + target_output (n.- target_offset (!size target))] + (if (n.<= source_input bytes) + (loop [idx 0] + (if (n.< bytes idx) + (exec (!write (n.+ target_offset idx) + (!read (n.+ source_offset idx) source) + target) + (recur (inc idx))) + (#try.Success target))) + (exception.throw ..cannot_copy_bytes [bytes source_input target_output])))))) + +(def: #export (slice offset length binary) + (-> Nat Nat Binary (Try Binary)) + (let [size (..!size binary) + limit (n.+ length offset)] + (if (n.<= size limit) + (with_expansions [<jvm> (as_is (#try.Success (java/util/Arrays::copyOfRange binary (.int offset) (.int limit))))] + (for {@.old <jvm> + @.jvm <jvm>} + + ## Default + (..copy length offset binary 0 (..create length)))) + (exception.throw ..slice_out_of_bounds [size offset length])))) + +(def: #export (drop offset binary) + (-> Nat Binary Binary) + (case offset + 0 binary + _ (let [distance (n.- offset (..!size binary))] + (case (..slice offset distance binary) + (#try.Success slice) + slice + + (#try.Failure _) + (..create 0))))) + +(implementation: #export monoid + (Monoid Binary) + + (def: identity + (..create 0)) + + (def: (compose left right) + (let [sizeL (!size left) + sizeR (!size right) + output (..create (n.+ sizeL sizeR))] + (exec + (..copy sizeL 0 left 0 output) + (..copy sizeR 0 right sizeL output) + output)))) diff --git a/stdlib/source/library/lux/data/bit.lux b/stdlib/source/library/lux/data/bit.lux new file mode 100644 index 000000000..5a62ecce5 --- /dev/null +++ b/stdlib/source/library/lux/data/bit.lux @@ -0,0 +1,59 @@ +(.module: + [library + [lux #* + [abstract + [monoid (#+ Monoid)] + [equivalence (#+ Equivalence)] + hash + [codec (#+ Codec)]] + [control + ["." function]]]]) + +(implementation: #export equivalence + (Equivalence Bit) + + (def: (= x y) + (if x + y + (not y)))) + +(implementation: #export hash + (Hash Bit) + + (def: &equivalence ..equivalence) + + (def: (hash value) + (case value + #0 2 + #1 3))) + +(template [<name> <identity> <op>] + [(implementation: #export <name> + (Monoid Bit) + + (def: identity <identity>) + (def: (compose x y) (<op> x y)))] + + [disjunction #0 or] + [conjunction #1 and] + ) + +(implementation: #export codec + (Codec Text Bit) + + (def: (encode x) + (if x + "#1" + "#0")) + + (def: (decode input) + (case input + "#1" (#.Right #1) + "#0" (#.Right #0) + _ (#.Left "Wrong syntax for Bit.")))) + +(def: #export complement + {#.doc (doc "Generates the complement of a predicate." + "That is a predicate that returns the oposite of the original predicate.")} + (All [a] (-> (-> a Bit) (-> a Bit))) + (function.compose not)) diff --git a/stdlib/source/library/lux/data/collection/array.lux b/stdlib/source/library/lux/data/collection/array.lux new file mode 100644 index 000000000..66a3abb6e --- /dev/null +++ b/stdlib/source/library/lux/data/collection/array.lux @@ -0,0 +1,388 @@ +(.module: + [library + [lux #* + ["@" target] + [abstract + [monoid (#+ Monoid)] + [functor (#+ Functor)] + [equivalence (#+ Equivalence)] + [fold (#+ Fold)] + [predicate (#+ Predicate)]] + [data + ["." product] + ["." maybe] + [collection + ["." list ("#\." fold)]]] + [math + [number + ["n" nat]]]]]) + +(def: #export type_name + "#Array") + +(type: #export (Array a) + {#.doc "Mutable arrays."} + (#.Primitive ..type_name (#.Cons a #.Nil))) + +(with_expansions [<index_type> (primitive "java.lang.Long") + <elem_type> (primitive "java.lang.Object") + <array_type> (type (Array <elem_type>))] + (for {@.jvm + (template: (!int value) + (|> value + (:as <index_type>) + "jvm object cast" + "jvm conversion long-to-int"))} + (as_is)) + + (def: #export (new size) + (All [a] (-> Nat (Array a))) + (for {@.old + (:assume ("jvm anewarray" "(java.lang.Object )" size)) + + @.jvm + (|> size + !int + "jvm array new object" + (: <array_type>) + :assume) + + @.js ("js array new" size) + @.python ("python array new" size) + @.lua ("lua array new" size) + @.ruby ("ruby array new" size) + @.php ("php array new" size) + @.scheme ("scheme array new" size)})) + + (def: #export (size array) + (All [a] (-> (Array a) Nat)) + (for {@.old + ("jvm arraylength" array) + + @.jvm + (|> array + (:as <array_type>) + "jvm array length object" + "jvm conversion int-to-long" + "jvm object cast" + (: <index_type>) + (:as Nat)) + + @.js ("js array length" array) + @.python ("python array length" array) + @.lua ("lua array length" array) + @.ruby ("ruby array length" array) + @.php ("php array length" array) + @.scheme ("scheme array length" array)})) + + (template: (!read <read> <null?>) + (let [output (<read> index array)] + (if (<null?> output) + #.None + (#.Some output)))) + + (def: #export (read index array) + (All [a] + (-> Nat (Array a) (Maybe a))) + (if (n.< (size array) index) + (for {@.old + (let [value ("jvm aaload" array index)] + (if ("jvm object null?" value) + #.None + (#.Some value))) + + @.jvm + (let [value (|> array + (:as <array_type>) + ("jvm array read object" (!int index)))] + (if ("jvm object null?" value) + #.None + (#.Some (:assume value)))) + + @.js (!read "js array read" "js object undefined?") + @.python (!read "python array read" "python object none?") + @.lua (!read "lua array read" "lua object nil?") + @.ruby (!read "ruby array read" "ruby object nil?") + @.php (!read "php array read" "php object null?") + @.scheme (!read "scheme array read" "scheme object nil?")}) + #.None)) + + (def: #export (write! index value array) + (All [a] + (-> Nat a (Array a) (Array a))) + (for {@.old + ("jvm aastore" array index value) + + @.jvm + (|> array + (:as <array_type>) + ("jvm array write object" (!int index) (:as <elem_type> value)) + :assume) + + @.js ("js array write" index value array) + @.python ("python array write" index value array) + @.lua ("lua array write" index value array) + @.ruby ("ruby array write" index value array) + @.php ("php array write" index value array) + @.scheme ("scheme array write" index value array)})) + + (def: #export (delete! index array) + (All [a] + (-> Nat (Array a) (Array a))) + (if (n.< (size array) index) + (for {@.old + (write! index (:assume ("jvm object null")) array) + + @.jvm + (write! index (:assume (: <elem_type> ("jvm object null"))) array) + + @.js ("js array delete" index array) + @.python ("python array delete" index array) + @.lua ("lua array delete" index array) + @.ruby ("ruby array delete" index array) + @.php ("php array delete" index array) + @.scheme ("scheme array delete" index array)}) + array)) + ) + +(def: #export (contains? index array) + (All [a] + (-> Nat (Array a) Bit)) + (case (..read index array) + (#.Some _) + true + + _ + false)) + +(def: #export (update! index transform array) + (All [a] + (-> Nat (-> a a) (Array a) (Array a))) + (case (read index array) + #.None + array + + (#.Some value) + (write! index (transform value) array))) + +(def: #export (upsert! index default transform array) + (All [a] + (-> Nat a (-> a a) (Array a) (Array a))) + (write! index + (|> array (read index) (maybe.default default) transform) + array)) + +(def: #export (copy! length src_start src_array dest_start dest_array) + (All [a] + (-> Nat Nat (Array a) Nat (Array a) + (Array a))) + (if (n.= 0 length) + dest_array + (list\fold (function (_ offset target) + (case (read (n.+ offset src_start) src_array) + #.None + target + + (#.Some value) + (write! (n.+ offset dest_start) value target))) + dest_array + (list.indices length)))) + +(def: #export (occupancy array) + {#.doc "Finds out how many cells in an array are occupied."} + (All [a] (-> (Array a) Nat)) + (list\fold (function (_ idx count) + (case (read idx array) + #.None + count + + (#.Some _) + (inc count))) + 0 + (list.indices (size array)))) + +(def: #export (vacancy array) + {#.doc "Finds out how many cells in an array are vacant."} + (All [a] (-> (Array a) Nat)) + (n.- (..occupancy array) (..size array))) + +(def: #export (filter! p xs) + (All [a] + (-> (Predicate a) (Array a) (Array a))) + (list\fold (function (_ idx xs') + (case (read idx xs) + #.None + xs' + + (#.Some x) + (if (p x) + xs' + (delete! idx xs')))) + xs + (list.indices (size xs)))) + +(def: #export (find p xs) + (All [a] + (-> (Predicate a) (Array a) (Maybe a))) + (let [arr_size (size xs)] + (loop [idx 0] + (if (n.< arr_size idx) + (case (read idx xs) + #.None + (recur (inc idx)) + + (#.Some x) + (if (p x) + (#.Some x) + (recur (inc idx)))) + #.None)))) + +(def: #export (find+ p xs) + {#.doc "Just like 'find', but with access to the index of each value."} + (All [a] + (-> (-> Nat a Bit) (Array a) (Maybe [Nat a]))) + (let [arr_size (size xs)] + (loop [idx 0] + (if (n.< arr_size idx) + (case (read idx xs) + #.None + (recur (inc idx)) + + (#.Some x) + (if (p idx x) + (#.Some [idx x]) + (recur (inc idx)))) + #.None)))) + +(def: #export (clone xs) + (All [a] (-> (Array a) (Array a))) + (let [arr_size (size xs)] + (list\fold (function (_ idx ys) + (case (read idx xs) + #.None + ys + + (#.Some x) + (write! idx x ys))) + (new arr_size) + (list.indices arr_size)))) + +(def: #export (from_list xs) + (All [a] (-> (List a) (Array a))) + (product.right (list\fold (function (_ x [idx arr]) + [(inc idx) (write! idx x arr)]) + [0 (new (list.size xs))] + xs))) + +(def: underflow Nat (dec 0)) + +(def: #export (to_list array) + (All [a] (-> (Array a) (List a))) + (loop [idx (dec (size array)) + output #.Nil] + (if (n.= ..underflow idx) + output + (recur (dec idx) + (case (read idx array) + (#.Some head) + (#.Cons head output) + + #.None + output))))) + +(def: #export (to_list' default array) + (All [a] (-> a (Array a) (List a))) + (loop [idx (dec (size array)) + output #.Nil] + (if (n.= ..underflow idx) + output + (recur (dec idx) + (#.Cons (maybe.default default (read idx array)) + output))))) + +(implementation: #export (equivalence (^open ",\.")) + (All [a] (-> (Equivalence a) (Equivalence (Array a)))) + + (def: (= xs ys) + (let [sxs (size xs) + sxy (size ys)] + (and (n.= sxy sxs) + (list\fold (function (_ idx prev) + (and prev + (case [(read idx xs) (read idx ys)] + [#.None #.None] + true + + [(#.Some x) (#.Some y)] + (,\= x y) + + _ + false))) + true + (list.indices sxs)))))) + +(implementation: #export monoid + (All [a] (Monoid (Array a))) + + (def: identity (new 0)) + + (def: (compose xs ys) + (let [sxs (size xs) + sxy (size ys)] + (|> (new (n.+ sxy sxs)) + (copy! sxs 0 xs 0) + (copy! sxy 0 ys sxs))))) + +(implementation: #export functor + (Functor Array) + + (def: (map f ma) + (let [arr_size (size ma)] + (if (n.= 0 arr_size) + (new arr_size) + (list\fold (function (_ idx mb) + (case (read idx ma) + #.None + mb + + (#.Some x) + (write! idx (f x) mb))) + (new arr_size) + (list.indices arr_size)) + )))) + +(implementation: #export fold + (Fold Array) + + (def: (fold f init xs) + (let [arr_size (size xs)] + (loop [so_far init + idx 0] + (if (n.< arr_size idx) + (case (read idx xs) + #.None + (recur so_far (inc idx)) + + (#.Some value) + (recur (f value so_far) (inc idx))) + so_far))))) + +(template [<name> <init> <op>] + [(def: #export (<name> predicate array) + (All [a] + (-> (Predicate a) (Predicate (Array a)))) + (let [size (..size array)] + (loop [idx 0] + (if (n.< size idx) + (case (..read idx array) + (#.Some value) + (<op> (predicate value) + (recur (inc idx))) + + #.None + (recur (inc idx))) + <init>))))] + + [every? true and] + [any? false or] + ) diff --git a/stdlib/source/library/lux/data/collection/bits.lux b/stdlib/source/library/lux/data/collection/bits.lux new file mode 100644 index 000000000..63e90f7c8 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/bits.lux @@ -0,0 +1,177 @@ +(.module: + [library + [lux (#- not and or) + [abstract + [equivalence (#+ Equivalence)]] + [control + pipe] + [data + ["." maybe] + [collection + ["." array (#+ Array) ("#\." fold)]]] + [math + [number + ["n" nat] + ["." i64]]]]]) + +(type: #export Chunk + I64) + +(def: #export chunk-size + i64.width) + +(type: #export Bits + (Array Chunk)) + +(def: empty-chunk + Chunk + (.i64 0)) + +(def: #export empty + Bits + (array.new 0)) + +(def: #export (size bits) + (-> Bits Nat) + (array\fold (function (_ chunk total) + (|> chunk i64.count (n.+ total))) + 0 + bits)) + +(def: #export (capacity bits) + (-> Bits Nat) + (|> bits array.size (n.* chunk-size))) + +(def: #export empty? + (-> Bits Bit) + (|>> size (n.= 0))) + +(def: #export (get index bits) + (-> Nat Bits Bit) + (let [[chunk-index bit-index] (n./% chunk-size index)] + (.and (n.< (array.size bits) chunk-index) + (|> (array.read chunk-index bits) + (maybe.default empty-chunk) + (i64.set? bit-index))))) + +(def: (chunk idx bits) + (-> Nat Bits Chunk) + (if (n.< (array.size bits) idx) + (|> bits (array.read idx) (maybe.default empty-chunk)) + empty-chunk)) + +(template [<name> <op>] + [(def: #export (<name> index input) + (-> Nat Bits Bits) + (let [[chunk-index bit-index] (n./% chunk-size index)] + (loop [size|output (n.max (inc chunk-index) + (array.size input)) + output ..empty] + (let [idx|output (dec size|output)] + (if (n.> 0 size|output) + (case (|> (..chunk idx|output input) + (cond> [(new> (n.= chunk-index idx|output) [])] + [(<op> bit-index)] + + ## else + []) + .nat) + 0 + ## TODO: Remove 'no-op' once new-luxc is the official compiler. + (let [no-op (recur (dec size|output) output)] + no-op) + + chunk + (|> (if (is? ..empty output) + (: Bits (array.new size|output)) + output) + (array.write! idx|output (.i64 chunk)) + (recur (dec size|output)))) + output)))))] + + [set i64.set] + [clear i64.clear] + [flip i64.flip] + ) + +(def: #export (intersects? reference sample) + (-> Bits Bits Bit) + (let [chunks (n.min (array.size reference) + (array.size sample))] + (loop [idx 0] + (if (n.< chunks idx) + (.or (|> (..chunk idx sample) + (i64.and (..chunk idx reference)) + ("lux i64 =" empty-chunk) + .not) + (recur (inc idx))) + #0)))) + +(def: #export (not input) + (-> Bits Bits) + (case (array.size input) + 0 + ..empty + + size|output + (loop [size|output size|output + output ..empty] + (let [idx (dec size|output)] + (case (|> input (..chunk idx) i64.not .nat) + 0 + (recur (dec size|output) output) + + chunk + (if (n.> 0 size|output) + (|> (if (is? ..empty output) + (: Bits (array.new size|output)) + output) + (array.write! idx (.i64 chunk)) + (recur (dec size|output))) + output)))))) + +(template [<name> <op>] + [(def: #export (<name> param subject) + (-> Bits Bits Bits) + (case (n.max (array.size param) + (array.size subject)) + 0 + ..empty + + size|output + (loop [size|output size|output + output ..empty] + (let [idx (dec size|output)] + (if (n.> 0 size|output) + (case (|> (..chunk idx subject) + (<op> (..chunk idx param)) + .nat) + 0 + (recur (dec size|output) output) + + chunk + (|> (if (is? ..empty output) + (: Bits (array.new size|output)) + output) + (array.write! idx (.i64 chunk)) + (recur (dec size|output)))) + output)))))] + + [and i64.and] + [or i64.or] + [xor i64.xor] + ) + +(implementation: #export equivalence + (Equivalence Bits) + + (def: (= reference sample) + (let [size (n.max (array.size reference) + (array.size sample))] + (loop [idx 0] + (if (n.< size idx) + (.and ("lux i64 =" + (..chunk idx reference) + (..chunk idx sample)) + (recur (inc idx))) + #1))))) diff --git a/stdlib/source/library/lux/data/collection/dictionary.lux b/stdlib/source/library/lux/data/collection/dictionary.lux new file mode 100644 index 000000000..3ae286db8 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/dictionary.lux @@ -0,0 +1,732 @@ +(.module: + [library + [lux #* + [abstract + [hash (#+ Hash)] + [equivalence (#+ Equivalence)] + [functor (#+ Functor)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." maybe] + ["." product] + [collection + ["." list ("#\." fold functor monoid)] + ["." array (#+ Array) ("#\." functor fold)]]] + [math + ["." number + ["n" nat] + ["." i64]]]]]) + +## This implementation of Hash Array Mapped Trie (HAMT) is based on +## Clojure's PersistentHashMap implementation. +## That one is further based on Phil Bagwell's Hash Array Mapped Trie. + +## Bitmaps are used to figure out which branches on a #Base node are +## populated. The number of bits that are 1s in a bitmap signal the +## size of the #Base node. +(type: BitMap + Nat) + +## Represents the position of a node in a BitMap. +## It's meant to be a single bit set on a 32-bit word. +## The position of the bit reflects whether an entry in an analogous +## position exists within a #Base, as reflected in its BitMap. +(type: BitPosition + Nat) + +## An index into an array. +(type: Index + Nat) + +## A hash-code derived from a key during tree-traversal. +(type: Hash_Code + Nat) + +## Represents the nesting level of a leaf or node, when looking-it-up +## while exploring the tree. +## Changes in levels are done by right-shifting the hashes of keys by +## the appropriate multiple of the branching-exponent. +## A shift of 0 means root level. +## A shift of (* branching_exponent 1) means level 2. +## A shift of (* branching_exponent N) means level N+1. +(type: Level + Nat) + +## Nodes for the tree data-structure that organizes the data inside +## Dictionaries. +(type: (Node k v) + (#Hierarchy Nat (Array (Node k v))) + (#Base BitMap + (Array (Either (Node k v) + [k v]))) + (#Collisions Hash_Code (Array [k v]))) + +## #Hierarchy nodes are meant to point down only to lower-level nodes. +(type: (Hierarchy k v) + [Nat (Array (Node k v))]) + +## #Base nodes may point down to other nodes, but also to leaves, +## which are KV-pairs. +(type: (Base k v) + (Array (Either (Node k v) + [k v]))) + +## #Collisions are collections of KV-pairs for which the key is +## different on each case, but their hashes are all the same (thus +## causing a collision). +(type: (Collisions k v) + (Array [k v])) + +## That bitmap for an empty #Base is 0. +## Which is the same as 0000 0000 0000 0000 0000 0000 0000 0000. +## Or 0x00000000. +## Which is 32 zeroes, since the branching factor is 32. +(def: clean_bitmap + BitMap + 0) + +## Bitmap position (while looking inside #Base nodes) is determined by +## getting 5 bits from a hash of the key being looked up and using +## them as an index into the array inside #Base. +## Since the data-structure can have multiple levels (and the hash has +## more than 5 bits), the binary-representation of the hash is shifted +## by 5 positions on each step (2^5 = 32, which is the branching +## factor). +## The initial shifting level, though, is 0 (which corresponds to the +## shift in the shallowest node on the tree, which is the root node). +(def: root_level + Level + 0) + +## The exponent to which 2 must be elevated, to reach the branching +## factor of the data-structure. +(def: branching_exponent + Nat + 5) + +## The threshold on which #Hierarchy nodes are demoted to #Base nodes, +## which is 1/4 of the branching factor (or a left-shift 2). +(def: demotion_threshold + Nat + (i64.left_shift (n.- 2 branching_exponent) 1)) + +## The threshold on which #Base nodes are promoted to #Hierarchy nodes, +## which is 1/2 of the branching factor (or a left-shift 1). +(def: promotion_threshold + Nat + (i64.left_shift (n.- 1 branching_exponent) 1)) + +## The size of hierarchy-nodes, which is 2^(branching-exponent). +(def: hierarchy_nodes_size + Nat + (i64.left_shift branching_exponent 1)) + +## The cannonical empty node, which is just an empty #Base node. +(def: empty + Node + (#Base clean_bitmap (array.new 0))) + +## Expands a copy of the array, to have 1 extra slot, which is used +## for storing the value. +(def: (insert! idx value old_array) + (All [a] (-> Index a (Array a) (Array a))) + (let [old_size (array.size old_array)] + (|> (array.new (inc old_size)) + (array.copy! idx 0 old_array 0) + (array.write! idx value) + (array.copy! (n.- idx old_size) idx old_array (inc idx))))) + +## Creates a copy of an array with an index set to a particular value. +(def: (update! idx value array) + (All [a] (-> Index a (Array a) (Array a))) + (|> array array.clone (array.write! idx value))) + +## Creates a clone of the array, with an empty position at index. +(def: (vacant! idx array) + (All [a] (-> Index (Array a) (Array a))) + (|> array array.clone (array.delete! idx))) + +## Shrinks a copy of the array by removing the space at index. +(def: (remove! idx array) + (All [a] (-> Index (Array a) (Array a))) + (let [new_size (dec (array.size array))] + (|> (array.new new_size) + (array.copy! idx 0 array 0) + (array.copy! (n.- idx new_size) (inc idx) array idx)))) + +## Increases the level-shift by the branching-exponent, to explore +## levels further down the tree. +(def: level_up + (-> Level Level) + (n.+ branching_exponent)) + +(def: hierarchy_mask + BitMap + (dec hierarchy_nodes_size)) + +## Gets the branching-factor sized section of the hash corresponding +## to a particular level, and uses that as an index into the array. +(def: (level_index level hash) + (-> Level Hash_Code Index) + (i64.and ..hierarchy_mask + (i64.right_shift level hash))) + +## A mechanism to go from indices to bit-positions. +(def: (->bit_position index) + (-> Index BitPosition) + (i64.left_shift index 1)) + +## The bit-position within a base that a given hash-code would have. +(def: (bit_position level hash) + (-> Level Hash_Code BitPosition) + (->bit_position (level_index level hash))) + +(def: (bit_position_is_set? bit bitmap) + (-> BitPosition BitMap Bit) + (|> bitmap + (i64.and bit) + (n.= clean_bitmap) + not)) + +## Figures out whether a bitmap only contains a single bit-position. +(def: only_bit_position? + (-> BitPosition BitMap Bit) + n.=) + +(def: (set_bit_position bit bitmap) + (-> BitPosition BitMap BitMap) + (i64.or bit bitmap)) + +(def: unset_bit_position + (-> BitPosition BitMap BitMap) + i64.xor) + +## Figures out the size of a bitmap-indexed array by counting all the +## 1s within the bitmap. +(def: bitmap_size + (-> BitMap Nat) + i64.count) + +## A mask that, for a given bit position, only allows all the 1s prior +## to it, which would indicate the bitmap-size (and, thus, index) +## associated with it. +(def: bit_position_mask + (-> BitPosition BitMap) + dec) + +## The index on the base array, based on its bit-position. +(def: (base_index bit_position bitmap) + (-> BitPosition BitMap Index) + (bitmap_size (i64.and (bit_position_mask bit_position) + bitmap))) + +## Produces the index of a KV-pair within a #Collisions node. +(def: (collision_index Hash<k> key colls) + (All [k v] (-> (Hash k) k (Collisions k v) (Maybe Index))) + (\ maybe.monad map product.left + (array.find+ (function (_ idx [key' val']) + (\ Hash<k> = key key')) + colls))) + +## When #Hierarchy nodes grow too small, they're demoted to #Base +## nodes to save space. +(def: (demote_hierarchy except_idx [h_size h_array]) + (All [k v] (-> Index (Hierarchy k v) [BitMap (Base k v)])) + (product.right (list\fold (function (_ idx [insertion_idx node]) + (let [[bitmap base] node] + (case (array.read idx h_array) + #.None [insertion_idx node] + (#.Some sub_node) (if (n.= except_idx idx) + [insertion_idx node] + [(inc insertion_idx) + [(set_bit_position (->bit_position idx) bitmap) + (array.write! insertion_idx (#.Left sub_node) base)]]) + ))) + [0 [clean_bitmap + (array.new (dec h_size))]] + (list.indices (array.size h_array))))) + +## When #Base nodes grow too large, they're promoted to #Hierarchy to +## add some depth to the tree and help keep its balance. +(def: hierarchy_indices (List Index) (list.indices hierarchy_nodes_size)) + +(def: (promote_base put' Hash<k> level bitmap base) + (All [k v] + (-> (-> Level Hash_Code k v (Hash k) (Node k v) (Node k v)) + (Hash k) Level + BitMap (Base k v) + (Array (Node k v)))) + (product.right (list\fold (function (_ hierarchy_idx (^@ default [base_idx h_array])) + (if (bit_position_is_set? (->bit_position hierarchy_idx) + bitmap) + [(inc base_idx) + (case (array.read base_idx base) + (#.Some (#.Left sub_node)) + (array.write! hierarchy_idx sub_node h_array) + + (#.Some (#.Right [key' val'])) + (array.write! hierarchy_idx + (put' (level_up level) (\ Hash<k> hash key') key' val' Hash<k> empty) + h_array) + + #.None + (undefined))] + default)) + [0 + (array.new hierarchy_nodes_size)] + hierarchy_indices))) + +## All empty nodes look the same (a #Base node with clean bitmap is +## used). +## So, this test is introduced to detect them. +(def: (empty?' node) + (All [k v] (-> (Node k v) Bit)) + (`` (case node + (#Base (~~ (static ..clean_bitmap)) _) + #1 + + _ + #0))) + +(def: (put' level hash key val Hash<k> node) + (All [k v] (-> Level Hash_Code k v (Hash k) (Node k v) (Node k v))) + (case node + ## For #Hierarchy nodes, check whether one can add the element to + ## a sub-node. If impossible, introduce a new singleton sub-node. + (#Hierarchy _size hierarchy) + (let [idx (level_index level hash) + [_size' sub_node] (case (array.read idx hierarchy) + (#.Some sub_node) + [_size sub_node] + + _ + [(inc _size) empty])] + (#Hierarchy _size' + (update! idx (put' (level_up level) hash key val Hash<k> sub_node) + hierarchy))) + + ## For #Base nodes, check if the corresponding BitPosition has + ## already been used. + (#Base bitmap base) + (let [bit (bit_position level hash)] + (if (bit_position_is_set? bit bitmap) + ## If so... + (let [idx (base_index bit bitmap)] + (case (array.read idx base) + ## If it's being used by a node, add the KV to it. + (#.Some (#.Left sub_node)) + (let [sub_node' (put' (level_up level) hash key val Hash<k> sub_node)] + (#Base bitmap (update! idx (#.Left sub_node') base))) + + ## Otherwise, if it's being used by a KV, compare the keys. + (#.Some (#.Right key' val')) + (if (\ Hash<k> = key key') + ## If the same key is found, replace the value. + (#Base bitmap (update! idx (#.Right key val) base)) + ## Otherwise, compare the hashes of the keys. + (#Base bitmap (update! idx + (#.Left (let [hash' (\ Hash<k> hash key')] + (if (n.= hash hash') + ## If the hashes are + ## the same, a new + ## #Collisions node + ## is added. + (#Collisions hash (|> (array.new 2) + (array.write! 0 [key' val']) + (array.write! 1 [key val]))) + ## Otherwise, one can + ## just keep using + ## #Base nodes, so + ## add both KV-pairs + ## to the empty one. + (let [next_level (level_up level)] + (|> empty + (put' next_level hash' key' val' Hash<k>) + (put' next_level hash key val Hash<k>)))))) + base))) + + #.None + (undefined))) + ## However, if the BitPosition has not been used yet, check + ## whether this #Base node is ready for a promotion. + (let [base_count (bitmap_size bitmap)] + (if (n.>= ..promotion_threshold base_count) + ## If so, promote it to a #Hierarchy node, and add the new + ## KV-pair as a singleton node to it. + (#Hierarchy (inc base_count) + (|> (promote_base put' Hash<k> level bitmap base) + (array.write! (level_index level hash) + (put' (level_up level) hash key val Hash<k> empty)))) + ## Otherwise, just resize the #Base node to accommodate the + ## new KV-pair. + (#Base (set_bit_position bit bitmap) + (insert! (base_index bit bitmap) (#.Right [key val]) base)))))) + + ## For #Collisions nodes, compare the hashes. + (#Collisions _hash _colls) + (if (n.= hash _hash) + ## If they're equal, that means the new KV contributes to the + ## collisions. + (case (collision_index Hash<k> key _colls) + ## If the key was already present in the collisions-list, its + ## value gets updated. + (#.Some coll_idx) + (#Collisions _hash (update! coll_idx [key val] _colls)) + + ## Otherwise, the KV-pair is added to the collisions-list. + #.None + (#Collisions _hash (insert! (array.size _colls) [key val] _colls))) + ## If the hashes are not equal, create a new #Base node that + ## contains the old #Collisions node, plus the new KV-pair. + (|> (#Base (bit_position level _hash) + (|> (array.new 1) + (array.write! 0 (#.Left node)))) + (put' level hash key val Hash<k>))) + )) + +(def: (remove' level hash key Hash<k> node) + (All [k v] (-> Level Hash_Code k (Hash k) (Node k v) (Node k v))) + (case node + ## For #Hierarchy nodes, find out if there's a valid sub-node for + ## the Hash-Code. + (#Hierarchy h_size h_array) + (let [idx (level_index level hash)] + (case (array.read idx h_array) + ## If not, there's nothing to remove. + #.None + node + + ## But if there is, try to remove the key from the sub-node. + (#.Some sub_node) + (let [sub_node' (remove' (level_up level) hash key Hash<k> sub_node)] + ## Then check if a removal was actually done. + (if (is? sub_node sub_node') + ## If not, then there's nothing to change here either. + node + ## But if the sub_removal yielded an empty sub_node... + (if (empty?' sub_node') + ## Check if it's due time for a demotion. + (if (n.<= demotion_threshold h_size) + ## If so, perform it. + (#Base (demote_hierarchy idx [h_size h_array])) + ## Otherwise, just clear the space. + (#Hierarchy (dec h_size) (vacant! idx h_array))) + ## But if the sub_removal yielded a non_empty node, then + ## just update the hiearchy branch. + (#Hierarchy h_size (update! idx sub_node' h_array))))))) + + ## For #Base nodes, check whether the BitPosition is set. + (#Base bitmap base) + (let [bit (bit_position level hash)] + (if (bit_position_is_set? bit bitmap) + (let [idx (base_index bit bitmap)] + (case (array.read idx base) + ## If set, check if it's a sub_node, and remove the KV + ## from it. + (#.Some (#.Left sub_node)) + (let [sub_node' (remove' (level_up level) hash key Hash<k> sub_node)] + ## Verify that it was removed. + (if (is? sub_node sub_node') + ## If not, there's also nothing to change here. + node + ## But if it came out empty... + (if (empty?' sub_node') + ### ... figure out whether that's the only position left. + (if (only_bit_position? bit bitmap) + ## If so, removing it leaves this node empty too. + empty + ## But if not, then just unset the position and + ## remove the node. + (#Base (unset_bit_position bit bitmap) + (remove! idx base))) + ## But, if it did not come out empty, then the + ## position is kept, and the node gets updated. + (#Base bitmap + (update! idx (#.Left sub_node') base))))) + + ## If, however, there was a KV-pair instead of a sub-node. + (#.Some (#.Right [key' val'])) + ## Check if the keys match. + (if (\ Hash<k> = key key') + ## If so, remove the KV-pair and unset the BitPosition. + (#Base (unset_bit_position bit bitmap) + (remove! idx base)) + ## Otherwise, there's nothing to remove. + node) + + #.None + (undefined))) + ## If the BitPosition is not set, there's nothing to remove. + node)) + + ## For #Collisions nodes, It need to find out if the key already existst. + (#Collisions _hash _colls) + (case (collision_index Hash<k> key _colls) + ## If not, then there's nothing to remove. + #.None + node + + ## But if so, then check the size of the collisions list. + (#.Some idx) + (if (n.= 1 (array.size _colls)) + ## If there's only one left, then removing it leaves us with + ## an empty node. + empty + ## Otherwise, just shrink the array by removing the KV-pair. + (#Collisions _hash (remove! idx _colls)))) + )) + +(def: (get' level hash key Hash<k> node) + (All [k v] (-> Level Hash_Code k (Hash k) (Node k v) (Maybe v))) + (case node + ## For #Hierarchy nodes, just look-up the key on its children. + (#Hierarchy _size hierarchy) + (case (array.read (level_index level hash) hierarchy) + #.None #.None + (#.Some sub_node) (get' (level_up level) hash key Hash<k> sub_node)) + + ## For #Base nodes, check the leaves, and recursively check the branches. + (#Base bitmap base) + (let [bit (bit_position level hash)] + (if (bit_position_is_set? bit bitmap) + (case (array.read (base_index bit bitmap) base) + (#.Some (#.Left sub_node)) + (get' (level_up level) hash key Hash<k> sub_node) + + (#.Some (#.Right [key' val'])) + (if (\ Hash<k> = key key') + (#.Some val') + #.None) + + #.None + (undefined)) + #.None)) + + ## For #Collisions nodes, do a linear scan of all the known KV-pairs. + (#Collisions _hash _colls) + (\ maybe.monad map product.right + (array.find (|>> product.left (\ Hash<k> = key)) + _colls)) + )) + +(def: (size' node) + (All [k v] (-> (Node k v) Nat)) + (case node + (#Hierarchy _size hierarchy) + (array\fold n.+ 0 (array\map size' hierarchy)) + + (#Base _ base) + (array\fold n.+ 0 (array\map (function (_ sub_node') + (case sub_node' + (#.Left sub_node) (size' sub_node) + (#.Right _) 1)) + base)) + + (#Collisions hash colls) + (array.size colls) + )) + +(def: (entries' node) + (All [k v] (-> (Node k v) (List [k v]))) + (case node + (#Hierarchy _size hierarchy) + (array\fold (function (_ sub_node tail) (list\compose (entries' sub_node) tail)) + #.Nil + hierarchy) + + (#Base bitmap base) + (array\fold (function (_ branch tail) + (case branch + (#.Left sub_node) + (list\compose (entries' sub_node) tail) + + (#.Right [key' val']) + (#.Cons [key' val'] tail))) + #.Nil + base) + + (#Collisions hash colls) + (array\fold (function (_ [key' val'] tail) (#.Cons [key' val'] tail)) + #.Nil + colls))) + +(type: #export (Dictionary k v) + {#.doc "A dictionary implemented as a Hash-Array Mapped Trie (HAMT)."} + {#hash (Hash k) + #root (Node k v)}) + +(def: #export key_hash + (All [k v] (-> (Dictionary k v) (Hash k))) + (get@ #..hash)) + +(def: #export (new Hash<k>) + (All [k v] (-> (Hash k) (Dictionary k v))) + {#hash Hash<k> + #root empty}) + +(def: #export (put key val dict) + (All [k v] (-> k v (Dictionary k v) (Dictionary k v))) + (let [[Hash<k> node] dict] + [Hash<k> (put' root_level (\ Hash<k> hash key) key val Hash<k> node)])) + +(def: #export (remove key dict) + (All [k v] (-> k (Dictionary k v) (Dictionary k v))) + (let [[Hash<k> node] dict] + [Hash<k> (remove' root_level (\ Hash<k> hash key) key Hash<k> node)])) + +(def: #export (get key dict) + (All [k v] (-> k (Dictionary k v) (Maybe v))) + (let [[Hash<k> node] dict] + (get' root_level (\ Hash<k> hash key) key Hash<k> node))) + +(def: #export (key? dict key) + (All [k v] (-> (Dictionary k v) k Bit)) + (case (get key dict) + #.None #0 + (#.Some _) #1)) + +(exception: #export key_already_exists) + +(def: #export (try_put key val dict) + {#.doc "Only puts the KV-pair if the key is not already present."} + (All [k v] (-> k v (Dictionary k v) (Try (Dictionary k v)))) + (case (get key dict) + #.None (#try.Success (put key val dict)) + (#.Some _) (exception.throw ..key_already_exists []))) + +(def: #export (update key f dict) + {#.doc "Transforms the value located at key (if available), using the given function."} + (All [k v] (-> k (-> v v) (Dictionary k v) (Dictionary k v))) + (case (get key dict) + #.None + dict + + (#.Some val) + (put key (f val) dict))) + +(def: #export (upsert key default f dict) + {#.doc (doc "Updates the value at the key; if it exists." + "Otherwise, puts a value by applying the function to a default.")} + (All [k v] (-> k v (-> v v) (Dictionary k v) (Dictionary k v))) + (..put key + (f (maybe.default default + (..get key dict))) + dict)) + +(def: #export size + (All [k v] (-> (Dictionary k v) Nat)) + (|>> product.right ..size')) + +(def: #export empty? + (All [k v] (-> (Dictionary k v) Bit)) + (|>> size (n.= 0))) + +(def: #export (entries dict) + (All [k v] (-> (Dictionary k v) (List [k v]))) + (entries' (product.right dict))) + +(def: #export (from_list Hash<k> kvs) + (All [k v] (-> (Hash k) (List [k v]) (Dictionary k v))) + (list\fold (function (_ [k v] dict) + (put k v dict)) + (new Hash<k>) + kvs)) + +(template [<name> <elem_type> <side>] + [(def: #export (<name> dict) + (All [k v] (-> (Dictionary k v) (List <elem_type>))) + (|> dict entries (list\map <side>)))] + + [keys k product.left] + [values v product.right] + ) + +(def: #export (merge dict2 dict1) + {#.doc (doc "Merges 2 dictionaries." + "If any collisions with keys occur, the values of dict2 will overwrite those of dict1.")} + (All [k v] (-> (Dictionary k v) (Dictionary k v) (Dictionary k v))) + (list\fold (function (_ [key val] dict) (put key val dict)) + dict1 + (entries dict2))) + +(def: #export (merge_with f dict2 dict1) + {#.doc (doc "Merges 2 dictionaries." + "If any collisions with keys occur, a new value will be computed by applying 'f' to the values of dict2 and dict1.")} + (All [k v] (-> (-> v v v) (Dictionary k v) (Dictionary k v) (Dictionary k v))) + (list\fold (function (_ [key val2] dict) + (case (get key dict) + #.None + (put key val2 dict) + + (#.Some val1) + (put key (f val2 val1) dict))) + dict1 + (entries dict2))) + +(def: #export (re_bind from_key to_key dict) + (All [k v] (-> k k (Dictionary k v) (Dictionary k v))) + (case (get from_key dict) + #.None + dict + + (#.Some val) + (|> dict + (remove from_key) + (put to_key val)))) + +(def: #export (select keys dict) + {#.doc "Creates a sub-set of the given dict, with only the specified keys."} + (All [k v] (-> (List k) (Dictionary k v) (Dictionary k v))) + (let [[Hash<k> _] dict] + (list\fold (function (_ key new_dict) + (case (get key dict) + #.None new_dict + (#.Some val) (put key val new_dict))) + (new Hash<k>) + keys))) + +(implementation: #export (equivalence (^open ",\.")) + (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) + + (def: (= reference subject) + (and (n.= (..size reference) + (..size subject)) + (list.every? (function (_ [k rv]) + (case (..get k subject) + (#.Some sv) + (,\= rv sv) + + _ + #0)) + (..entries reference))))) + +(implementation: functor' + (All [k] (Functor (Node k))) + + (def: (map f fa) + (case fa + (#Hierarchy size hierarchy) + (#Hierarchy size (array\map (map f) hierarchy)) + + (#Base bitmap base) + (#Base bitmap (array\map (function (_ either) + (case either + (#.Left fa') + (#.Left (map f fa')) + + (#.Right [k v]) + (#.Right [k (f v)]))) + base)) + + (#Collisions hash collisions) + (#Collisions hash (array\map (function (_ [k v]) + [k (f v)]) + collisions))))) + +(implementation: #export functor + (All [k] (Functor (Dictionary k))) + + (def: (map f fa) + (update@ #root (\ ..functor' map f) fa))) diff --git a/stdlib/source/library/lux/data/collection/dictionary/ordered.lux b/stdlib/source/library/lux/data/collection/dictionary/ordered.lux new file mode 100644 index 000000000..5c8b82ebd --- /dev/null +++ b/stdlib/source/library/lux/data/collection/dictionary/ordered.lux @@ -0,0 +1,584 @@ +(.module: + [library + [lux #* + [abstract + equivalence + [monad (#+ Monad do)] + ["." order (#+ Order)]] + [data + ["p" product] + ["." maybe] + [collection + ["." list ("#\." monoid fold)]]] + [macro + ["." code]] + [math + [number + ["n" nat]]]]]) + +(def: error_message + "Invariant violation") + +(type: Color + #Red + #Black) + +(type: (Node k v) + {#color Color + #key k + #value v + #left (Maybe (Node k v)) + #right (Maybe (Node k v))}) + +(template [<create> <color>] + [(def: (<create> key value left right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + {#color <color> + #key key + #value value + #left left + #right right})] + + [red #Red] + [black #Black] + ) + +(type: #export (Dictionary k v) + {#&order (Order k) + #root (Maybe (Node k v))}) + +(def: #export (new order) + (All [k v] (-> (Order k) (Dictionary k v))) + {#&order order + #root #.None}) + +## TODO: Doing inneficient access of Order functions due to compiler bug. +## TODO: Must improve it as soon as bug is fixed. +(def: #export (get key dict) + (All [k v] (-> k (Dictionary k v) (Maybe v))) + (let [## (^open "_\.") (get@ #&order dict) + ] + (loop [node (get@ #root dict)] + (case node + #.None + #.None + + (#.Some node) + (let [node_key (get@ #key node)] + (cond (\ dict = node_key key) + ## (_\= node_key key) + (#.Some (get@ #value node)) + + (\ dict < node_key key) + ## (_\< node_key key) + (recur (get@ #left node)) + + ## (_\> (get@ #key node) key) + (recur (get@ #right node)))) + )))) + +## TODO: Doing inneficient access of Order functions due to compiler bug. +## TODO: Must improve it as soon as bug is fixed. +(def: #export (key? dict key) + (All [k v] (-> (Dictionary k v) k Bit)) + (let [## (^open "_\.") (get@ #&order dict) + ] + (loop [node (get@ #root dict)] + (case node + #.None + #0 + + (#.Some node) + (let [node_key (get@ #key node)] + (or (\ dict = node_key key) + ## (_\= node_key key) + (if (\ dict < node_key key) + ## (_\< node_key key) + (recur (get@ #left node)) + (recur (get@ #right node))))))))) + +(template [<name> <side>] + [(def: #export (<name> dict) + (All [k v] (-> (Dictionary k v) (Maybe v))) + (case (get@ #root dict) + #.None + #.None + + (#.Some node) + (loop [node node] + (case (get@ <side> node) + #.None + (#.Some (get@ #value node)) + + (#.Some side) + (recur side)))))] + + [min #left] + [max #right] + ) + +(def: #export (size dict) + (All [k v] (-> (Dictionary k v) Nat)) + (loop [node (get@ #root dict)] + (case node + #.None + 0 + + (#.Some node) + (inc (n.+ (recur (get@ #left node)) + (recur (get@ #right node))))))) + +(def: #export empty? + (All [k v] (-> (Dictionary k v) Bit)) + (|>> ..size (n.= 0))) + +(template [<name> <other_color> <self_color> <no_change>] + [(def: (<name> self) + (All [k v] (-> (Node k v) (Node k v))) + (case (get@ #color self) + <other_color> + (set@ #color <self_color> self) + + <self_color> + <no_change> + ))] + + [blacken #Red #Black self] + [redden #Black #Red (error! error_message)] + ) + +(def: (balance_left_add parent self) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (with_expansions + [<default_behavior> (as_is (black (get@ #key parent) + (get@ #value parent) + (#.Some self) + (get@ #right parent)))] + (case (get@ #color self) + #Red + (case (get@ #left self) + (^multi (#.Some left) + [(get@ #color left) #Red]) + (red (get@ #key self) + (get@ #value self) + (#.Some (blacken left)) + (#.Some (black (get@ #key parent) + (get@ #value parent) + (get@ #right self) + (get@ #right parent)))) + + _ + (case (get@ #right self) + (^multi (#.Some right) + [(get@ #color right) #Red]) + (red (get@ #key right) + (get@ #value right) + (#.Some (black (get@ #key self) + (get@ #value self) + (get@ #left self) + (get@ #left right))) + (#.Some (black (get@ #key parent) + (get@ #value parent) + (get@ #right right) + (get@ #right parent)))) + + _ + <default_behavior>)) + + #Black + <default_behavior> + ))) + +(def: (balance_right_add parent self) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (with_expansions + [<default_behavior> (as_is (black (get@ #key parent) + (get@ #value parent) + (get@ #left parent) + (#.Some self)))] + (case (get@ #color self) + #Red + (case (get@ #right self) + (^multi (#.Some right) + [(get@ #color right) #Red]) + (red (get@ #key self) + (get@ #value self) + (#.Some (black (get@ #key parent) + (get@ #value parent) + (get@ #left parent) + (get@ #left self))) + (#.Some (blacken right))) + + _ + (case (get@ #left self) + (^multi (#.Some left) + [(get@ #color left) #Red]) + (red (get@ #key left) + (get@ #value left) + (#.Some (black (get@ #key parent) + (get@ #value parent) + (get@ #left parent) + (get@ #left left))) + (#.Some (black (get@ #key self) + (get@ #value self) + (get@ #right left) + (get@ #right self)))) + + _ + <default_behavior>)) + + #Black + <default_behavior> + ))) + +(def: (add_left addition center) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (case (get@ #color center) + #Red + (red (get@ #key center) (get@ #value center) (#.Some addition) (get@ #right center)) + + #Black + (balance_left_add center addition) + )) + +(def: (add_right addition center) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (case (get@ #color center) + #Red + (red (get@ #key center) (get@ #value center) (get@ #left center) (#.Some addition)) + + #Black + (balance_right_add center addition) + )) + +(def: #export (put key value dict) + (All [k v] (-> k v (Dictionary k v) (Dictionary k v))) + (let [(^open "_\.") (get@ #&order dict) + root' (loop [?root (get@ #root dict)] + (case ?root + #.None + (#.Some (red key value #.None #.None)) + + (#.Some root) + (let [reference (get@ #key root)] + (`` (cond (~~ (template [<comp> <tag> <add>] + [(<comp> reference key) + (let [side_root (get@ <tag> root) + outcome (recur side_root)] + (if (is? side_root outcome) + ?root + (#.Some (<add> (maybe.assume outcome) + root))))] + + [_\< #left add_left] + [(order.> (get@ #&order dict)) #right add_right] + )) + + ## (_\= reference key) + (#.Some (set@ #value value root)) + ))) + ))] + (set@ #root root' dict))) + +(def: (left_balance key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?left + (^multi (#.Some left) + [(get@ #color left) #Red] + [(get@ #left left) (#.Some left>>left)] + [(get@ #color left>>left) #Red]) + (red (get@ #key left) + (get@ #value left) + (#.Some (blacken left>>left)) + (#.Some (black key value (get@ #right left) ?right))) + + (^multi (#.Some left) + [(get@ #color left) #Red] + [(get@ #right left) (#.Some left>>right)] + [(get@ #color left>>right) #Red]) + (red (get@ #key left>>right) + (get@ #value left>>right) + (#.Some (black (get@ #key left) + (get@ #value left) + (get@ #left left) + (get@ #left left>>right))) + (#.Some (black key value + (get@ #right left>>right) + ?right))) + + _ + (black key value ?left ?right))) + +(def: (right_balance key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?right + (^multi (#.Some right) + [(get@ #color right) #Red] + [(get@ #right right) (#.Some right>>right)] + [(get@ #color right>>right) #Red]) + (red (get@ #key right) + (get@ #value right) + (#.Some (black key value ?left (get@ #left right))) + (#.Some (blacken right>>right))) + + (^multi (#.Some right) + [(get@ #color right) #Red] + [(get@ #left right) (#.Some right>>left)] + [(get@ #color right>>left) #Red]) + (red (get@ #key right>>left) + (get@ #value right>>left) + (#.Some (black key value ?left (get@ #left right>>left))) + (#.Some (black (get@ #key right) + (get@ #value right) + (get@ #right right>>left) + (get@ #right right)))) + + _ + (black key value ?left ?right))) + +(def: (balance_left_remove key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?left + (^multi (#.Some left) + [(get@ #color left) #Red]) + (red key value (#.Some (blacken left)) ?right) + + _ + (case ?right + (^multi (#.Some right) + [(get@ #color right) #Black]) + (right_balance key value ?left (#.Some (redden right))) + + (^multi (#.Some right) + [(get@ #color right) #Red] + [(get@ #left right) (#.Some right>>left)] + [(get@ #color right>>left) #Black]) + (red (get@ #key right>>left) + (get@ #value right>>left) + (#.Some (black key value ?left (get@ #left right>>left))) + (#.Some (right_balance (get@ #key right) + (get@ #value right) + (get@ #right right>>left) + (\ maybe.functor map redden (get@ #right right))))) + + _ + (error! error_message)) + )) + +(def: (balance_right_remove key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?right + (^multi (#.Some right) + [(get@ #color right) #Red]) + (red key value ?left (#.Some (blacken right))) + + _ + (case ?left + (^multi (#.Some left) + [(get@ #color left) #Black]) + (left_balance key value (#.Some (redden left)) ?right) + + (^multi (#.Some left) + [(get@ #color left) #Red] + [(get@ #right left) (#.Some left>>right)] + [(get@ #color left>>right) #Black]) + (red (get@ #key left>>right) + (get@ #value left>>right) + (#.Some (left_balance (get@ #key left) + (get@ #value left) + (\ maybe.functor map redden (get@ #left left)) + (get@ #left left>>right))) + (#.Some (black key value (get@ #right left>>right) ?right))) + + _ + (error! error_message) + ))) + +(def: (prepend ?left ?right) + (All [k v] (-> (Maybe (Node k v)) (Maybe (Node k v)) (Maybe (Node k v)))) + (case [?left ?right] + [#.None _] + ?right + + [_ #.None] + ?left + + [(#.Some left) (#.Some right)] + (case [(get@ #color left) (get@ #color right)] + [#Red #Red] + (do maybe.monad + [fused (prepend (get@ #right left) (get@ #right right))] + (case (get@ #color fused) + #Red + (wrap (red (get@ #key fused) + (get@ #value fused) + (#.Some (red (get@ #key left) + (get@ #value left) + (get@ #left left) + (get@ #left fused))) + (#.Some (red (get@ #key right) + (get@ #value right) + (get@ #right fused) + (get@ #right right))))) + + #Black + (wrap (red (get@ #key left) + (get@ #value left) + (get@ #left left) + (#.Some (red (get@ #key right) + (get@ #value right) + (#.Some fused) + (get@ #right right))))))) + + [#Red #Black] + (#.Some (red (get@ #key left) + (get@ #value left) + (get@ #left left) + (prepend (get@ #right left) + ?right))) + + [#Black #Red] + (#.Some (red (get@ #key right) + (get@ #value right) + (prepend ?left + (get@ #left right)) + (get@ #right right))) + + [#Black #Black] + (do maybe.monad + [fused (prepend (get@ #right left) (get@ #left right))] + (case (get@ #color fused) + #Red + (wrap (red (get@ #key fused) + (get@ #value fused) + (#.Some (black (get@ #key left) + (get@ #value left) + (get@ #left left) + (get@ #left fused))) + (#.Some (black (get@ #key right) + (get@ #value right) + (get@ #right fused) + (get@ #right right))))) + + #Black + (wrap (balance_left_remove (get@ #key left) + (get@ #value left) + (get@ #left left) + (#.Some (black (get@ #key right) + (get@ #value right) + (#.Some fused) + (get@ #right right))))) + )) + ) + + _ + (undefined))) + +(def: #export (remove key dict) + (All [k v] (-> k (Dictionary k v) (Dictionary k v))) + (let [(^open "_\.") (get@ #&order dict) + [?root found?] (loop [?root (get@ #root dict)] + (case ?root + #.None + [#.None #0] + + (#.Some root) + (let [root_key (get@ #key root) + root_val (get@ #value root)] + (if (_\= root_key key) + [(prepend (get@ #left root) + (get@ #right root)) + #1] + (let [go_left? (_\< root_key key)] + (case (recur (if go_left? + (get@ #left root) + (get@ #right root))) + [#.None #0] + [#.None #0] + + [side_outcome _] + (if go_left? + (case (get@ #left root) + (^multi (#.Some left) + [(get@ #color left) #Black]) + [(#.Some (balance_left_remove root_key root_val side_outcome (get@ #right root))) + #0] + + _ + [(#.Some (red root_key root_val side_outcome (get@ #right root))) + #0]) + (case (get@ #right root) + (^multi (#.Some right) + [(get@ #color right) #Black]) + [(#.Some (balance_right_remove root_key root_val (get@ #left root) side_outcome)) + #0] + + _ + [(#.Some (red root_key root_val (get@ #left root) side_outcome)) + #0]) + ))) + )) + ))] + (case ?root + #.None + (if found? + (set@ #root ?root dict) + dict) + + (#.Some root) + (set@ #root (#.Some (blacken root)) dict) + ))) + +(def: #export (update key transform dict) + (All [k v] (-> k (-> v v) (Dictionary k v) (Dictionary k v))) + (case (..get key dict) + (#.Some old) + (..put key (transform old) dict) + + #.None + dict)) + +(def: #export (from_list Order<l> list) + (All [k v] (-> (Order k) (List [k v]) (Dictionary k v))) + (list\fold (function (_ [key value] dict) + (put key value dict)) + (new Order<l>) + list)) + +(template [<name> <type> <output>] + [(def: #export (<name> dict) + (All [k v] (-> (Dictionary k v) (List <type>))) + (loop [node (get@ #root dict)] + (case node + #.None + (list) + + (#.Some node') + ($_ list\compose + (recur (get@ #left node')) + (list <output>) + (recur (get@ #right node'))))))] + + [entries [k v] [(get@ #key node') (get@ #value node')]] + [keys k (get@ #key node')] + [values v (get@ #value node')] + ) + +(implementation: #export (equivalence (^open ",\.")) + (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) + + (def: (= reference sample) + (let [(^open "/\.") (get@ #&order reference)] + (loop [entriesR (entries reference) + entriesS (entries sample)] + (case [entriesR entriesS] + [#.Nil #.Nil] + #1 + + [(#.Cons [keyR valueR] entriesR') (#.Cons [keyS valueS] entriesS')] + (and (/\= keyR keyS) + (,\= valueR valueS) + (recur entriesR' entriesS')) + + _ + #0))))) diff --git a/stdlib/source/library/lux/data/collection/dictionary/plist.lux b/stdlib/source/library/lux/data/collection/dictionary/plist.lux new file mode 100644 index 000000000..f3f51c779 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/dictionary/plist.lux @@ -0,0 +1,98 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [data + ["." product] + ["." text ("#\." equivalence)] + [collection + ["." list ("#\." functor)]]] + [math + [number + ["n" nat]]]]]) + +(type: #export (PList a) + (List [Text a])) + +(def: #export empty + PList + #.Nil) + +(def: #export size + (All [a] (-> (PList a) Nat)) + list.size) + +(def: #export empty? + (All [a] (-> (PList a) Bit)) + (|>> ..size (n.= 0))) + +(def: #export (get key properties) + (All [a] (-> Text (PList a) (Maybe a))) + (case properties + #.Nil + #.None + + (#.Cons [k' v'] properties') + (if (text\= key k') + (#.Some v') + (get key properties')))) + +(template [<name> <type> <access>] + [(def: #export <name> + (All [a] (-> (PList a) (List <type>))) + (list\map <access>))] + + [keys Text product.left] + [values a product.right] + ) + +(def: #export (contains? key properties) + (All [a] (-> Text (PList a) Bit)) + (case (..get key properties) + (#.Some _) + true + + #.None + false)) + +(def: #export (put key val properties) + (All [a] (-> Text a (PList a) (PList a))) + (case properties + #.Nil + (list [key val]) + + (#.Cons [k' v'] properties') + (if (text\= key k') + (#.Cons [key val] + properties') + (#.Cons [k' v'] + (put key val properties'))))) + +(def: #export (update key f properties) + (All [a] (-> Text (-> a a) (PList a) (PList a))) + (case properties + #.Nil + #.Nil + + (#.Cons [k' v'] properties') + (if (text\= key k') + (#.Cons [k' (f v')] properties') + (#.Cons [k' v'] (update key f properties'))))) + +(def: #export (remove key properties) + (All [a] (-> Text (PList a) (PList a))) + (case properties + #.Nil + properties + + (#.Cons [k' v'] properties') + (if (text\= key k') + properties' + (#.Cons [k' v'] + (remove key properties'))))) + +(def: #export equivalence + (All [a] (-> (Equivalence a) (Equivalence (PList a)))) + (|>> (product.equivalence text.equivalence) + list.equivalence)) diff --git a/stdlib/source/library/lux/data/collection/list.lux b/stdlib/source/library/lux/data/collection/list.lux new file mode 100644 index 000000000..166b4c87b --- /dev/null +++ b/stdlib/source/library/lux/data/collection/list.lux @@ -0,0 +1,616 @@ +(.module: + [library + [lux #* + ["@" target] + [abstract + [monoid (#+ Monoid)] + [apply (#+ Apply)] + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + [fold (#+ Fold)] + [predicate (#+ Predicate)] + ["." functor (#+ Functor)] + ["." monad (#+ do Monad)] + ["." enum]] + [data + ["." bit] + ["." product]] + [math + [number + ["n" nat]]]]]) + +## (type: (List a) +## #Nil +## (#Cons a (List a))) + +(implementation: #export fold + (Fold List) + + (def: (fold f init xs) + (case xs + #.Nil + init + + (#.Cons x xs') + (fold f (f x init) xs')))) + +(def: #export (folds f init inputs) + (All [a b] (-> (-> a b b) b (List a) (List b))) + (case inputs + #.Nil + (list init) + + (#.Cons [head tail]) + (#.Cons [init (folds f (f head init) tail)]))) + +(def: #export (reverse xs) + (All [a] + (-> (List a) (List a))) + (fold (function (_ head tail) (#.Cons head tail)) + #.Nil + xs)) + +(def: #export (filter keep? xs) + (All [a] + (-> (Predicate a) (List a) (List a))) + (case xs + #.Nil + #.Nil + + (#.Cons x xs') + (if (keep? x) + (#.Cons x (filter keep? xs')) + (filter keep? xs')))) + +(def: #export (partition satisfies? list) + {#.doc "Divide the list into all elements that satisfy a predicate, and all elements that do not."} + (All [a] (-> (Predicate a) (List a) [(List a) (List a)])) + (case list + #.Nil + [#.Nil #.Nil] + + (#.Cons head tail) + (let [[in out] (partition satisfies? tail)] + (if (satisfies? head) + [(#.Cons head in) out] + [in (#.Cons head out)])))) + +(def: #export (as_pairs xs) + {#.doc (doc "Cut the list into pairs of 2." + "Caveat emptor: If the list has an uneven number of elements, the last one will be skipped.")} + (All [a] (-> (List a) (List [a a]))) + (case xs + (^ (list& x1 x2 xs')) + (#.Cons [x1 x2] (as_pairs xs')) + + _ + #.Nil)) + +(template [<name> <then> <else>] + [(def: #export (<name> n xs) + (All [a] + (-> Nat (List a) (List a))) + (if (n.> 0 n) + (case xs + #.Nil + #.Nil + + (#.Cons x xs') + <then>) + <else>))] + + [take (#.Cons x (take (dec n) xs')) #.Nil] + [drop (drop (dec n) xs') xs] + ) + +(template [<name> <then> <else>] + [(def: #export (<name> predicate xs) + (All [a] + (-> (Predicate a) (List a) (List a))) + (case xs + #.Nil + #.Nil + + (#.Cons x xs') + (if (predicate x) + <then> + <else>)))] + + [take_while (#.Cons x (take_while predicate xs')) #.Nil] + [drop_while (drop_while predicate xs') xs] + ) + +(def: #export (split n xs) + (All [a] + (-> Nat (List a) [(List a) (List a)])) + (if (n.> 0 n) + (case xs + #.Nil + [#.Nil #.Nil] + + (#.Cons x xs') + (let [[tail rest] (split (dec n) xs')] + [(#.Cons x tail) rest])) + [#.Nil xs])) + +(def: (split_with' predicate ys xs) + (All [a] + (-> (Predicate a) (List a) (List a) [(List a) (List a)])) + (case xs + #.Nil + [ys xs] + + (#.Cons x xs') + (if (predicate x) + (split_with' predicate (#.Cons x ys) xs') + [ys xs]))) + +(def: #export (split_with predicate xs) + {#.doc "Segment the list by using a predicate to tell when to cut."} + (All [a] + (-> (Predicate a) (List a) [(List a) (List a)])) + (let [[ys' xs'] (split_with' predicate #.Nil xs)] + [(reverse ys') xs'])) + +(def: #export (chunk n xs) + {#.doc "Segment the list in chunks of size N."} + (All [a] (-> Nat (List a) (List (List a)))) + (case xs + #.Nil + (list) + + _ + (let [[pre post] (split n xs)] + (#.Cons pre (chunk n post))))) + +(def: #export (repeat n x) + {#.doc "A list of the value x, repeated n times."} + (All [a] + (-> Nat a (List a))) + (if (n.> 0 n) + (#.Cons x (repeat (dec n) x)) + #.Nil)) + +(def: (iterate' f x) + (All [a] + (-> (-> a (Maybe a)) a (List a))) + (case (f x) + (#.Some x') + (#.Cons x (iterate' f x')) + + #.None + (list))) + +(def: #export (iterate f x) + {#.doc "Generates a list element by element until the function returns #.None."} + (All [a] + (-> (-> a (Maybe a)) a (List a))) + (case (f x) + (#.Some x') + (#.Cons x (iterate' f x')) + + #.None + (list x))) + +(def: #export (one check xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #.Nil + #.None + + (#.Cons x xs') + (case (check x) + (#.Some output) + (#.Some output) + + #.None + (one check xs')))) + +(def: #export (all check xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (List b))) + (for {## TODO: Stop relying on this ASAP. + @.js + (fold (function (_ head tail) + (case (check head) + (#.Some head) + (#.Cons head tail) + + #.None + tail)) + #.Nil + (reverse xs))} + (case xs + #.Nil + #.Nil + + (#.Cons x xs') + (case (check x) + (#.Some output) + (#.Cons output (all check xs')) + + #.None + (all check xs'))))) + +(def: #export (find predicate xs) + {#.doc "Returns the first value in the list for which the predicate is #1."} + (All [a] + (-> (Predicate a) (List a) (Maybe a))) + (..one (function (_ value) + (if (predicate value) + (#.Some value) + #.None)) + xs)) + +(def: #export (interpose sep xs) + {#.doc "Puts a value between every two elements in the list."} + (All [a] + (-> a (List a) (List a))) + (case xs + #.Nil + xs + + (#.Cons x #.Nil) + xs + + (#.Cons x xs') + (list& x sep (interpose sep xs')))) + +(def: #export (size list) + (All [a] (-> (List a) Nat)) + (fold (function (_ _ acc) (n.+ 1 acc)) 0 list)) + +(template [<name> <init> <op>] + [(def: #export (<name> predicate xs) + (All [a] + (-> (Predicate a) (List a) Bit)) + (loop [xs xs] + (case xs + #.Nil + <init> + + (#.Cons x xs') + (case (predicate x) + <init> + (recur xs') + + output + output))))] + + [every? #1 and] + [any? #0 or] + ) + +(def: #export (nth i xs) + {#.doc "Fetches the element at the specified index."} + (All [a] + (-> Nat (List a) (Maybe a))) + (case xs + #.Nil + #.None + + (#.Cons x xs') + (if (n.= 0 i) + (#.Some x) + (nth (dec i) xs')))) + +(implementation: #export (equivalence Equivalence<a>) + (All [a] (-> (Equivalence a) (Equivalence (List a)))) + + (def: (= xs ys) + (case [xs ys] + [#.Nil #.Nil] + #1 + + [(#.Cons x xs') (#.Cons y ys')] + (and (\ Equivalence<a> = x y) + (= xs' ys')) + + [_ _] + #0 + ))) + +(implementation: #export (hash super) + (All [a] (-> (Hash a) (Hash (List a)))) + + (def: &equivalence + (..equivalence (\ super &equivalence))) + + (def: hash + (\ ..fold fold + (function (_ member hash) + (n.+ (\ super hash member) hash)) + 0))) + +(implementation: #export monoid + (All [a] (Monoid (List a))) + + (def: identity #.Nil) + (def: (compose xs ys) + (case xs + #.Nil + ys + + (#.Cons x xs') + (#.Cons x (compose xs' ys))))) + +(open: "." ..monoid) + +(implementation: #export functor + (Functor List) + + (def: (map f ma) + (case ma + #.Nil + #.Nil + + (#.Cons a ma') + (#.Cons (f a) (map f ma'))))) + +(open: "." ..functor) + +(implementation: #export apply + (Apply List) + + (def: &functor ..functor) + + (def: (apply ff fa) + (case ff + #.Nil + #.Nil + + (#.Cons f ff') + (compose (map f fa) (apply ff' fa))))) + +(implementation: #export monad + (Monad List) + + (def: &functor ..functor) + + (def: (wrap a) + (#.Cons a #.Nil)) + + (def: join (|>> reverse (fold compose identity)))) + +(def: #export (sort < xs) + (All [a] (-> (-> a a Bit) (List a) (List a))) + (case xs + #.Nil + (list) + + (#.Cons x xs') + (let [[pre post] (fold (function (_ x' [pre post]) + (if (< x x') + [(#.Cons x' pre) post] + [pre (#.Cons x' post)])) + [(list) (list)] + xs')] + ($_ compose (sort < pre) (list x) (sort < post))))) + +(def: #export (empty? xs) + (All [a] (Predicate (List a))) + (case xs + #.Nil + true + + _ + false)) + +(def: #export (member? eq xs x) + (All [a] (-> (Equivalence a) (List a) a Bit)) + (case xs + #.Nil + #0 + + (#.Cons x' xs') + (or (\ eq = x x') + (member? eq xs' x)))) + +(template [<name> <output> <side> <doc>] + [(def: #export (<name> xs) + {#.doc <doc>} + (All [a] (-> (List a) (Maybe <output>))) + (case xs + #.Nil + #.None + + (#.Cons x xs') + (#.Some <side>)))] + + [head a x "Returns the first element of a list."] + [tail (List a) xs' "For a list of size N, returns the N-1 elements after the first one."] + ) + +(def: #export (indices size) + {#.doc "Produces all the valid indices for a given size."} + (All [a] (-> Nat (List Nat))) + (if (n.= 0 size) + (list) + (|> size dec (enum.range n.enum 0)))) + +(def: (identifier$ name) + (-> Text Code) + [["" 0 0] (#.Identifier "" name)]) + +(def: (nat@encode value) + (-> Nat Text) + (loop [input value + output ""] + (let [digit (case (n.% 10 input) + 0 "0" + 1 "1" + 2 "2" + 3 "3" + 4 "4" + 5 "5" + 6 "6" + 7 "7" + 8 "8" + 9 "9" + _ (undefined)) + output' ("lux text concat" digit output) + input' (n./ 10 input)] + (if (n.= 0 input') + output' + (recur input' output'))))) + +(macro: #export (zip tokens state) + {#.doc (doc "Create list zippers with the specified number of input lists." + (def: #export zip/2 (zip 2)) + (def: #export zip/3 (zip 3)) + ((zip 3) xs ys zs))} + (case tokens + (^ (list [_ (#.Nat num_lists)])) + (if (n.> 0 num_lists) + (let [(^open ".") ..functor + indices (..indices num_lists) + type_vars (: (List Code) (map (|>> nat@encode identifier$) indices)) + zip_type (` (All [(~+ type_vars)] + (-> (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var))))) + type_vars)) + (List [(~+ type_vars)])))) + vars+lists (|> indices + (map inc) + (map (function (_ idx) + (let [base (nat@encode idx)] + [(identifier$ base) + (identifier$ ("lux text concat" base "'"))])))) + pattern (` [(~+ (map (function (_ [v vs]) (` (#.Cons (~ v) (~ vs)))) + vars+lists))]) + g!step (identifier$ "0step0") + g!blank (identifier$ "0,0") + list_vars (map product.right vars+lists) + code (` (: (~ zip_type) + (function ((~ g!step) (~+ list_vars)) + (case [(~+ list_vars)] + (~ pattern) + (#.Cons [(~+ (map product.left vars+lists))] + ((~ g!step) (~+ list_vars))) + + (~ g!blank) + #.Nil))))] + (#.Right [state (list code)])) + (#.Left "Cannot zip 0 lists.")) + + _ + (#.Left "Wrong syntax for zip"))) + +(def: #export zip/2 (zip 2)) +(def: #export zip/3 (zip 3)) + +(macro: #export (zip_with tokens state) + {#.doc (doc "Create list zippers with the specified number of input lists." + (def: #export zip_with/2 (zip_with 2)) + (def: #export zip_with/3 (zip_with 3)) + ((zip_with 2) + xs ys))} + (case tokens + (^ (list [_ (#.Nat num_lists)])) + (if (n.> 0 num_lists) + (let [(^open ".") ..functor + indices (..indices num_lists) + g!return_type (identifier$ "0return_type0") + g!func (identifier$ "0func0") + type_vars (: (List Code) (map (|>> nat@encode identifier$) indices)) + zip_type (` (All [(~+ type_vars) (~ g!return_type)] + (-> (-> (~+ type_vars) (~ g!return_type)) + (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var))))) + type_vars)) + (List (~ g!return_type))))) + vars+lists (|> indices + (map inc) + (map (function (_ idx) + (let [base (nat@encode idx)] + [(identifier$ base) + (identifier$ ("lux text concat" base "'"))])))) + pattern (` [(~+ (map (function (_ [v vs]) (` (#.Cons (~ v) (~ vs)))) + vars+lists))]) + g!step (identifier$ "0step0") + g!blank (identifier$ "0,0") + list_vars (map product.right vars+lists) + code (` (: (~ zip_type) + (function ((~ g!step) (~ g!func) (~+ list_vars)) + (case [(~+ list_vars)] + (~ pattern) + (#.Cons ((~ g!func) (~+ (map product.left vars+lists))) + ((~ g!step) (~ g!func) (~+ list_vars))) + + (~ g!blank) + #.Nil))))] + (#.Right [state (list code)])) + (#.Left "Cannot zip_with 0 lists.")) + + _ + (#.Left "Wrong syntax for zip_with"))) + +(def: #export zip_with/2 (zip_with 2)) +(def: #export zip_with/3 (zip_with 3)) + +(def: #export (last xs) + (All [a] (-> (List a) (Maybe a))) + (case xs + #.Nil + #.None + + (#.Cons x #.Nil) + (#.Some x) + + (#.Cons x xs') + (last xs'))) + +(def: #export (inits xs) + {#.doc (doc "For a list of size N, returns the first N-1 elements." + "Empty lists will result in a #.None value being returned instead.")} + (All [a] (-> (List a) (Maybe (List a)))) + (case xs + #.Nil + #.None + + (#.Cons x #.Nil) + (#.Some #.Nil) + + (#.Cons x xs') + (case (inits xs') + #.None + (undefined) + + (#.Some tail) + (#.Some (#.Cons x tail))) + )) + +(def: #export (concat xss) + (All [a] (-> (List (List a)) (List a))) + (\ ..monad join xss)) + +(implementation: #export (with monad) + (All [M] (-> (Monad M) (Monad (All [a] (M (List a)))))) + + (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor)) + + (def: wrap (|>> (\ ..monad wrap) (\ monad wrap))) + + (def: (join MlMla) + (do {! monad} + [lMla MlMla + ## TODO: Remove this version ASAP and use one below. + lla (for {@.old + (: (($ 0) (List (List ($ 1)))) + (monad.seq ! lMla))} + (monad.seq ! lMla))] + (wrap (concat lla))))) + +(def: #export (lift monad) + (All [M a] (-> (Monad M) (-> (M a) (M (List a))))) + (\ monad map (\ ..monad wrap))) + +(def: #export (enumeration xs) + {#.doc "Pairs every element in the list with its index, starting at 0."} + (All [a] (-> (List a) (List [Nat a]))) + (loop [idx 0 + xs xs] + (case xs + #.Nil + #.Nil + + (#.Cons x xs') + (#.Cons [idx x] (recur (inc idx) xs'))))) diff --git a/stdlib/source/library/lux/data/collection/queue.lux b/stdlib/source/library/lux/data/collection/queue.lux new file mode 100644 index 000000000..cb4d9106f --- /dev/null +++ b/stdlib/source/library/lux/data/collection/queue.lux @@ -0,0 +1,93 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [functor (#+ Functor)]] + [data + [collection + ["." list ("#\." monoid functor)]]] + [math + [number + ["n" nat]]]]]) + +(type: #export (Queue a) + {#front (List a) + #rear (List a)}) + +(def: #export empty + Queue + {#front (list) + #rear (list)}) + +(def: #export (from_list entries) + (All [a] (-> (List a) (Queue a))) + {#front entries + #rear (list)}) + +(def: #export (to_list queue) + (All [a] (-> (Queue a) (List a))) + (let [(^slots [#front #rear]) queue] + (list\compose front (list.reverse rear)))) + +(def: #export peek + (All [a] (-> (Queue a) (Maybe a))) + (|>> (get@ #front) list.head)) + +(def: #export (size queue) + (All [a] (-> (Queue a) Nat)) + (let [(^slots [#front #rear]) queue] + (n.+ (list.size front) + (list.size rear)))) + +(def: #export empty? + (All [a] (-> (Queue a) Bit)) + (|>> (get@ #front) list.empty?)) + +(def: #export (member? equivalence queue member) + (All [a] (-> (Equivalence a) (Queue a) a Bit)) + (let [(^slots [#front #rear]) queue] + (or (list.member? equivalence front member) + (list.member? equivalence rear member)))) + +(def: #export (pop queue) + (All [a] (-> (Queue a) (Queue a))) + (case (get@ #front queue) + ## Empty... + (^ (list)) + queue + + ## Front has dried up... + (^ (list _)) + (|> queue + (set@ #front (list.reverse (get@ #rear queue))) + (set@ #rear (list))) + + ## Consume front! + (^ (list& _ front')) + (|> queue + (set@ #front front')))) + +(def: #export (push val queue) + (All [a] (-> a (Queue a) (Queue a))) + (case (get@ #front queue) + #.Nil + (set@ #front (list val) queue) + + _ + (update@ #rear (|>> (#.Cons val)) queue))) + +(implementation: #export (equivalence super) + (All [a] (-> (Equivalence a) (Equivalence (Queue a)))) + + (def: (= reference subject) + (\ (list.equivalence super) = + (..to_list reference) + (..to_list subject)))) + +(implementation: #export functor + (Functor Queue) + + (def: (map f fa) + {#front (|> fa (get@ #front) (list\map f)) + #rear (|> fa (get@ #rear) (list\map f))})) diff --git a/stdlib/source/library/lux/data/collection/queue/priority.lux b/stdlib/source/library/lux/data/collection/queue/priority.lux new file mode 100644 index 000000000..d044a5023 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/queue/priority.lux @@ -0,0 +1,121 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ do Monad)]] + [data + ["." maybe] + [collection + ["." tree #_ + ["#" finger (#+ Tree)]]]] + [math + [number + ["n" nat ("#\." interval)]]] + [type (#+ :by_example) + [abstract (#+ abstract: :abstraction :representation)]]]]) + +(type: #export Priority + Nat) + +(def: #export max Priority n\top) +(def: #export min Priority n\bottom) + +(def: builder + (tree.builder n.maximum)) + +(def: :@: + (:by_example [@] + (tree.Builder @ Priority) + ..builder + + @)) + +(abstract: #export (Queue a) + (Maybe (Tree :@: Priority a)) + + (def: #export empty + Queue + (:abstraction #.None)) + + (def: #export (peek queue) + (All [a] (-> (Queue a) (Maybe a))) + (do maybe.monad + [tree (:representation queue)] + (tree.search (n.= (tree.tag tree)) + tree))) + + (def: #export (size queue) + (All [a] (-> (Queue a) Nat)) + (case (:representation queue) + #.None + 0 + + (#.Some tree) + (loop [node tree] + (case (tree.root node) + (0 #0 _) + 1 + + (0 #1 [left right]) + (n.+ (recur left) (recur right)))))) + + (def: #export (member? equivalence queue member) + (All [a] (-> (Equivalence a) (Queue a) a Bit)) + (case (:representation queue) + #.None + false + + (#.Some tree) + (loop [node tree] + (case (tree.root node) + (0 #0 reference) + (\ equivalence = reference member) + + (0 #1 [left right]) + (or (recur left) + (recur right)))))) + + (def: #export (pop queue) + (All [a] (-> (Queue a) (Queue a))) + (:abstraction + (do maybe.monad + [tree (:representation queue) + #let [highest_priority (tree.tag tree)]] + (loop [node tree] + (case (tree.root node) + (0 #0 reference) + (if (n.= highest_priority (tree.tag node)) + #.None + (#.Some node)) + + (0 #1 left right) + (if (n.= highest_priority (tree.tag left)) + (case (recur left) + #.None + (#.Some right) + + (#.Some =left) + (#.Some (\ ..builder branch =left right))) + (case (recur right) + #.None + (#.Some left) + + (#.Some =right) + (#.Some (\ ..builder branch left =right))))))))) + + (def: #export (push priority value queue) + (All [a] (-> Priority a (Queue a) (Queue a))) + (let [addition (\ ..builder leaf priority value)] + (:abstraction + (case (:representation queue) + #.None + (#.Some addition) + + (#.Some tree) + (#.Some (\ ..builder branch tree addition)))))) + ) + +(def: #export empty? + (All [a] (-> (Queue a) Bit)) + (|>> ..size (n.= 0))) diff --git a/stdlib/source/library/lux/data/collection/row.lux b/stdlib/source/library/lux/data/collection/row.lux new file mode 100644 index 000000000..0bb304c35 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/row.lux @@ -0,0 +1,490 @@ +## https://hypirion.com/musings/understanding-persistent-vector-pt-1 +## https://hypirion.com/musings/understanding-persistent-vector-pt-2 +## https://hypirion.com/musings/understanding-persistent-vector-pt-3 +(.module: + [library + [lux #* + ["@" target] + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)] + [equivalence (#+ Equivalence)] + [monoid (#+ Monoid)] + [fold (#+ Fold)] + [predicate (#+ Predicate)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["p" parser + ["s" code (#+ Parser)]]] + [data + ["." maybe] + ["." product] + [collection + ["." list ("#\." fold functor monoid)] + ["." array (#+ Array) ("#\." functor fold)]]] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code]] + [math + [number + ["." i64] + ["n" nat]]]]]) + +(type: (Node a) + (#Base (Array a)) + (#Hierarchy (Array (Node a)))) + +(type: (Base a) (Array a)) +(type: (Hierarchy a) (Array (Node a))) + +(type: Level Nat) + +(type: Index Nat) + +(def: branching_exponent + Nat + 5) + +(def: root_level + Level + 0) + +(template [<name> <op>] + [(def: <name> + (-> Level Level) + (<op> branching_exponent))] + + [level_up n.+] + [level_down n.-] + ) + +(def: full_node_size + Nat + (i64.left_shift branching_exponent 1)) + +(def: branch_idx_mask + Nat + (dec full_node_size)) + +(def: branch_idx + (-> Index Index) + (i64.and branch_idx_mask)) + +(def: (new_hierarchy _) + (All [a] (-> Any (Hierarchy a))) + (array.new full_node_size)) + +(def: (tail_off row_size) + (-> Nat Nat) + (if (n.< full_node_size row_size) + 0 + (|> (dec row_size) + (i64.right_shift branching_exponent) + (i64.left_shift branching_exponent)))) + +(def: (new_path level tail) + (All [a] (-> Level (Base a) (Node a))) + (if (n.= 0 level) + (#Base tail) + (|> (new_hierarchy []) + (array.write! 0 (new_path (level_down level) tail)) + #Hierarchy))) + +(def: (new_tail singleton) + (All [a] (-> a (Base a))) + (|> (array.new 1) + (array.write! 0 singleton))) + +(def: (push_tail size level tail parent) + (All [a] (-> Nat Level (Base a) (Hierarchy a) (Hierarchy a))) + (let [sub_idx (branch_idx (i64.right_shift level (dec size))) + ## If we're currently on a bottom node + sub_node (if (n.= branching_exponent level) + ## Just add the tail to it + (#Base tail) + ## Otherwise, check whether there's a vacant spot + (case (array.read sub_idx parent) + ## If so, set the path to the tail + #.None + (new_path (level_down level) tail) + ## If not, push the tail onto the sub_node. + (#.Some (#Hierarchy sub_node)) + (#Hierarchy (push_tail size (level_down level) tail sub_node)) + + _ + (undefined)) + )] + (|> (array.clone parent) + (array.write! sub_idx sub_node)))) + +(def: (expand_tail val tail) + (All [a] (-> a (Base a) (Base a))) + (let [tail_size (array.size tail)] + (|> (array.new (inc tail_size)) + (array.copy! tail_size 0 tail 0) + (array.write! tail_size val)))) + +(def: (put' level idx val hierarchy) + (All [a] (-> Level Index a (Hierarchy a) (Hierarchy a))) + (let [sub_idx (branch_idx (i64.right_shift level idx))] + (case (array.read sub_idx hierarchy) + (#.Some (#Hierarchy sub_node)) + (|> (array.clone hierarchy) + (array.write! sub_idx (#Hierarchy (put' (level_down level) idx val sub_node)))) + + (^multi (#.Some (#Base base)) + (n.= 0 (level_down level))) + (|> (array.clone hierarchy) + (array.write! sub_idx (|> (array.clone base) + (array.write! (branch_idx idx) val) + #Base))) + + _ + (undefined)))) + +(def: (pop_tail size level hierarchy) + (All [a] (-> Nat Level (Hierarchy a) (Maybe (Hierarchy a)))) + (let [sub_idx (branch_idx (i64.right_shift level (n.- 2 size)))] + (cond (n.= 0 sub_idx) + #.None + + (n.> branching_exponent level) + (do maybe.monad + [base|hierarchy (array.read sub_idx hierarchy) + sub (case base|hierarchy + (#Hierarchy sub) + (pop_tail size (level_down level) sub) + + (#Base _) + (undefined))] + (|> (array.clone hierarchy) + (array.write! sub_idx (#Hierarchy sub)) + #.Some)) + + ## Else... + (|> (array.clone hierarchy) + (array.delete! sub_idx) + #.Some) + ))) + +(def: (to_list' node) + (All [a] (-> (Node a) (List a))) + (case node + (#Base base) + (array.to_list base) + + (#Hierarchy hierarchy) + (|> hierarchy + array.to_list + list.reverse + (list\fold (function (_ sub acc) (list\compose (to_list' sub) acc)) + #.Nil)))) + +(type: #export (Row a) + {#level Level + #size Nat + #root (Hierarchy a) + #tail (Base a)}) + +(def: #export empty + Row + {#level (level_up root_level) + #size 0 + #root (array.new full_node_size) + #tail (array.new 0)}) + +(def: #export (size row) + (All [a] (-> (Row a) Nat)) + (get@ #size row)) + +(def: #export (add val row) + (All [a] (-> a (Row a) (Row a))) + ## Check if there is room in the tail. + (let [row_size (get@ #size row)] + (if (|> row_size (n.- (tail_off row_size)) (n.< full_node_size)) + ## If so, append to it. + (|> row + (update@ #size inc) + (update@ #tail (expand_tail val))) + ## Otherwise, push tail into the tree + ## -------------------------------------------------------- + ## Will the root experience an overflow with this addition? + (|> (if (n.> (i64.left_shift (get@ #level row) 1) + (i64.right_shift branching_exponent row_size)) + ## If so, a brand-new root must be established, that is + ## 1-level taller. + (|> row + (set@ #root (|> (for {@.old + (: (Hierarchy ($ 0)) + (new_hierarchy []))} + (new_hierarchy [])) + (array.write! 0 (#Hierarchy (get@ #root row))) + (array.write! 1 (new_path (get@ #level row) (get@ #tail row))))) + (update@ #level level_up)) + ## Otherwise, just push the current tail onto the root. + (|> row + (update@ #root (push_tail row_size (get@ #level row) (get@ #tail row))))) + ## Finally, update the size of the row and grow a new + ## tail with the new element as it's sole member. + (update@ #size inc) + (set@ #tail (new_tail val))) + ))) + +(exception: incorrect_row_structure) + +(exception: #export [a] (index_out_of_bounds {row (Row a)} {index Nat}) + (exception.report ["Size" (\ n.decimal encode (get@ #size row))] + ["Index" (\ n.decimal encode index)])) + +(exception: base_was_not_found) + +(def: #export (within_bounds? row idx) + (All [a] (-> (Row a) Nat Bit)) + (n.< (get@ #size row) idx)) + +(def: (base_for idx row) + (All [a] (-> Index (Row a) (Try (Base a)))) + (if (within_bounds? row idx) + (if (n.>= (tail_off (get@ #size row)) idx) + (#try.Success (get@ #tail row)) + (loop [level (get@ #level row) + hierarchy (get@ #root row)] + (case [(n.> branching_exponent level) + (array.read (branch_idx (i64.right_shift level idx)) hierarchy)] + [#1 (#.Some (#Hierarchy sub))] + (recur (level_down level) sub) + + [#0 (#.Some (#Base base))] + (#try.Success base) + + [_ #.None] + (exception.throw ..base_was_not_found []) + + _ + (exception.throw ..incorrect_row_structure [])))) + (exception.throw ..index_out_of_bounds [row idx]))) + +(def: #export (nth idx row) + (All [a] (-> Nat (Row a) (Try a))) + (do try.monad + [base (base_for idx row)] + (case (array.read (branch_idx idx) base) + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..incorrect_row_structure [])))) + +(def: #export (put idx val row) + (All [a] (-> Nat a (Row a) (Try (Row a)))) + (let [row_size (get@ #size row)] + (if (within_bounds? row idx) + (#try.Success (if (n.>= (tail_off row_size) idx) + (update@ #tail (for {@.old + (: (-> (Base ($ 0)) (Base ($ 0))) + (|>> array.clone (array.write! (branch_idx idx) val)))} + (|>> array.clone (array.write! (branch_idx idx) val))) + row) + (update@ #root (put' (get@ #level row) idx val) + row))) + (exception.throw ..index_out_of_bounds [row idx])))) + +(def: #export (update idx f row) + (All [a] (-> Nat (-> a a) (Row a) (Try (Row a)))) + (do try.monad + [val (..nth idx row)] + (..put idx (f val) row))) + +(def: #export (pop row) + (All [a] (-> (Row a) (Row a))) + (case (get@ #size row) + 0 + empty + + 1 + empty + + row_size + (if (|> row_size (n.- (tail_off row_size)) (n.> 1)) + (let [old_tail (get@ #tail row) + new_tail_size (dec (array.size old_tail))] + (|> row + (update@ #size dec) + (set@ #tail (|> (array.new new_tail_size) + (array.copy! new_tail_size 0 old_tail 0))))) + (maybe.assume + (do maybe.monad + [new_tail (base_for (n.- 2 row_size) row) + #let [[level' root'] (let [init_level (get@ #level row)] + (loop [level init_level + root (maybe.default (new_hierarchy []) + (pop_tail row_size init_level (get@ #root row)))] + (if (n.> branching_exponent level) + (case [(array.read 1 root) (array.read 0 root)] + [#.None (#.Some (#Hierarchy sub_node))] + (recur (level_down level) sub_node) + + ## [#.None (#.Some (#Base _))] + ## (undefined) + + _ + [level root]) + [level root])))]] + (wrap (|> row + (update@ #size dec) + (set@ #level level') + (set@ #root root') + (set@ #tail new_tail)))))) + )) + +(def: #export (to_list row) + (All [a] (-> (Row a) (List a))) + (list\compose (to_list' (#Hierarchy (get@ #root row))) + (to_list' (#Base (get@ #tail row))))) + +(def: #export from_list + (All [a] (-> (List a) (Row a))) + (list\fold ..add ..empty)) + +(def: #export (member? a/Equivalence row val) + (All [a] (-> (Equivalence a) (Row a) a Bit)) + (list.member? a/Equivalence (to_list row) val)) + +(def: #export empty? + (All [a] (-> (Row a) Bit)) + (|>> (get@ #size) (n.= 0))) + +(syntax: #export (row {elems (p.some s.any)}) + {#.doc (doc "Row literals." + (row +10 +20 +30 +40))} + (wrap (list (` (..from_list (list (~+ elems))))))) + +(implementation: (node_equivalence Equivalence<a>) + (All [a] (-> (Equivalence a) (Equivalence (Node a)))) + + (def: (= v1 v2) + (case [v1 v2] + [(#Base b1) (#Base b2)] + (\ (array.equivalence Equivalence<a>) = b1 b2) + + [(#Hierarchy h1) (#Hierarchy h2)] + (\ (array.equivalence (node_equivalence Equivalence<a>)) = h1 h2) + + _ + #0))) + +(implementation: #export (equivalence Equivalence<a>) + (All [a] (-> (Equivalence a) (Equivalence (Row a)))) + + (def: (= v1 v2) + (and (n.= (get@ #size v1) (get@ #size v2)) + (let [(^open "node\.") (node_equivalence Equivalence<a>)] + (and (node\= (#Base (get@ #tail v1)) + (#Base (get@ #tail v2))) + (node\= (#Hierarchy (get@ #root v1)) + (#Hierarchy (get@ #root v2)))))))) + +(implementation: node_fold + (Fold Node) + + (def: (fold f init xs) + (case xs + (#Base base) + (array\fold f init base) + + (#Hierarchy hierarchy) + (array\fold (function (_ node init') (fold f init' node)) + init + hierarchy)))) + +(implementation: #export fold + (Fold Row) + + (def: (fold f init xs) + (let [(^open ".") node_fold] + (fold f + (fold f + init + (#Hierarchy (get@ #root xs))) + (#Base (get@ #tail xs)))))) + +(implementation: #export monoid + (All [a] (Monoid (Row a))) + + (def: identity ..empty) + + (def: (compose xs ys) + (list\fold add xs (..to_list ys)))) + +(implementation: node_functor + (Functor Node) + + (def: (map f xs) + (case xs + (#Base base) + (#Base (array\map f base)) + + (#Hierarchy hierarchy) + (#Hierarchy (array\map (map f) hierarchy))))) + +(implementation: #export functor + (Functor Row) + + (def: (map f xs) + {#level (get@ #level xs) + #size (get@ #size xs) + #root (|> xs (get@ #root) (array\map (\ node_functor map f))) + #tail (|> xs (get@ #tail) (array\map f))})) + +(implementation: #export apply + (Apply Row) + + (def: &functor ..functor) + + (def: (apply ff fa) + (let [(^open ".") ..functor + (^open ".") ..fold + (^open ".") ..monoid + results (map (function (_ f) (map f fa)) + ff)] + (fold compose identity results)))) + +(implementation: #export monad + (Monad Row) + + (def: &functor ..functor) + + (def: wrap (|>> row)) + + (def: join + (let [(^open ".") ..fold + (^open ".") ..monoid] + (fold (function (_ post pre) (compose pre post)) identity)))) + +(def: #export reverse + (All [a] (-> (Row a) (Row a))) + (|>> ..to_list list.reverse (list\fold add ..empty))) + +(template [<name> <array> <init> <op>] + [(def: #export <name> + (All [a] + (-> (Predicate a) (Row a) Bit)) + (let [help (: (All [a] + (-> (Predicate a) (Node a) Bit)) + (function (help predicate node) + (case node + (#Base base) + (<array> predicate base) + + (#Hierarchy hierarchy) + (<array> (help predicate) hierarchy))))] + (function (<name> predicate row) + (let [(^slots [#root #tail]) row] + (<op> (help predicate (#Hierarchy root)) + (help predicate (#Base tail)))))))] + + [every? array.every? #1 and] + [any? array.any? #0 or] + ) diff --git a/stdlib/source/library/lux/data/collection/sequence.lux b/stdlib/source/library/lux/data/collection/sequence.lux new file mode 100644 index 000000000..a7fa5cb75 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/sequence.lux @@ -0,0 +1,151 @@ +(.module: + [library + [lux #* + [abstract + [functor (#+ Functor)] + [comonad (#+ CoMonad)]] + [control + ["//" continuation (#+ Cont)] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code]] + [data + ["." bit] + [collection + ["." list ("#\." monad)]]] + [math + [number + ["n" nat]]]]]) + +(type: #export (Sequence a) + {#.doc "An infinite sequence of values."} + (Cont [a (Sequence a)])) + +(def: #export (iterate f x) + {#.doc "Create a sequence by applying a function to a value, and to its result, on and on..."} + (All [a] + (-> (-> a a) a (Sequence a))) + (//.pending [x (iterate f (f x))])) + +(def: #export (repeat x) + {#.doc "Repeat a value forever."} + (All [a] + (-> a (Sequence a))) + (//.pending [x (repeat x)])) + +(def: #export (cycle [start next]) + {#.doc (doc "Go over the elements of a list forever." + "The list should not be empty.")} + (All [a] + (-> [a (List a)] (Sequence a))) + (loop [head start + tail next] + (//.pending [head (case tail + #.Nil + (recur start next) + + (#.Cons head' tail') + (recur head' tail'))]))) + +(template [<name> <return>] + [(def: #export (<name> sequence) + (All [a] (-> (Sequence a) <return>)) + (let [[head tail] (//.run sequence)] + <name>))] + + [head a] + [tail (Sequence a)] + ) + +(def: #export (nth idx sequence) + (All [a] (-> Nat (Sequence a) a)) + (let [[head tail] (//.run sequence)] + (case idx + 0 head + _ (nth (dec idx) tail)))) + +(template [<taker> <dropper> <splitter> <pred_type> <pred_test> <pred_step>] + [(def: #export (<taker> pred xs) + (All [a] + (-> <pred_type> (Sequence a) (List a))) + (let [[x xs'] (//.run xs)] + (if <pred_test> + (list& x (<taker> <pred_step> xs')) + (list)))) + + (def: #export (<dropper> pred xs) + (All [a] + (-> <pred_type> (Sequence a) (Sequence a))) + (let [[x xs'] (//.run xs)] + (if <pred_test> + (<dropper> <pred_step> xs') + xs))) + + (def: #export (<splitter> pred xs) + (All [a] + (-> <pred_type> (Sequence a) [(List a) (Sequence a)])) + (let [[x xs'] (//.run xs)] + (if <pred_test> + (let [[tail next] (<splitter> <pred_step> xs')] + [(#.Cons [x tail]) next]) + [(list) xs])))] + + [take_while drop_while split_while (-> a Bit) (pred x) pred] + [take drop split Nat (n.> 0 pred) (dec pred)] + ) + +(def: #export (unfold step init) + {#.doc "A stateful way of infinitely calculating the values of a sequence."} + (All [a b] + (-> (-> a [a b]) a (Sequence b))) + (let [[next x] (step init)] + (//.pending [x (unfold step next)]))) + +(def: #export (filter predicate sequence) + (All [a] (-> (-> a Bit) (Sequence a) (Sequence a))) + (let [[head tail] (//.run sequence)] + (if (predicate head) + (//.pending [head (filter predicate tail)]) + (filter predicate tail)))) + +(def: #export (partition left? xs) + {#.doc (doc "Split a sequence in two based on a predicate." + "The left side contains all entries for which the predicate is #1." + "The right side contains all entries for which the predicate is #0.")} + (All [a] (-> (-> a Bit) (Sequence a) [(Sequence a) (Sequence a)])) + [(filter left? xs) (filter (bit.complement left?) xs)]) + +(implementation: #export functor + (Functor Sequence) + + (def: (map f fa) + (let [[head tail] (//.run fa)] + (//.pending [(f head) (map f tail)])))) + +(implementation: #export comonad + (CoMonad Sequence) + + (def: &functor ..functor) + + (def: unwrap head) + + (def: (split wa) + (let [[head tail] (//.run wa)] + (//.pending [wa (split tail)])))) + +(syntax: #export (^sequence& {patterns (<code>.form (<>.many <code>.any))} + body + {branches (<>.some <code>.any)}) + {#.doc (doc "Allows destructuring of sequences in pattern-matching expressions." + "Caveat emptor: Only use it for destructuring, and not for testing values within the sequences." + (let [(^sequence& x y z _tail) (some_sequence_func +1 +2 +3)] + (func x y z)))} + (with_gensyms [g!sequence] + (let [body+ (` (let [(~+ (list\join (list\map (function (_ pattern) + (list (` [(~ pattern) (~ g!sequence)]) + (` ((~! //.run) (~ g!sequence))))) + patterns)))] + (~ body)))] + (wrap (list& g!sequence body+ branches))))) diff --git a/stdlib/source/library/lux/data/collection/set.lux b/stdlib/source/library/lux/data/collection/set.lux new file mode 100644 index 000000000..0ae6cee25 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/set.lux @@ -0,0 +1,105 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + [predicate (#+ Predicate)] + [monoid (#+ Monoid)]] + [data + [collection + ["." list ("#\." fold)]]] + [math + [number + ["n" nat]]]]] + ["." // #_ + ["#" dictionary (#+ Dictionary)]]) + +(type: #export (Set a) + (Dictionary a Any)) + +(def: #export member_hash + (All [a] (-> (Set a) (Hash a))) + //.key_hash) + +(def: #export new + (All [a] (-> (Hash a) (Set a))) + //.new) + +(def: #export size + (All [a] (-> (Set a) Nat)) + //.size) + +(def: #export (add elem set) + (All [a] (-> a (Set a) (Set a))) + (|> set (//.put elem []))) + +(def: #export remove + (All [a] (-> a (Set a) (Set a))) + //.remove) + +(def: #export member? + (All [a] (-> (Set a) a Bit)) + //.key?) + +(def: #export to_list + (All [a] (-> (Set a) (List a))) + //.keys) + +(def: #export union + (All [a] (-> (Set a) (Set a) (Set a))) + //.merge) + +(def: #export (difference sub base) + (All [a] (-> (Set a) (Set a) (Set a))) + (list\fold ..remove base (..to_list sub))) + +(def: #export (intersection filter base) + (All [a] (-> (Set a) (Set a) (Set a))) + (//.select (//.keys filter) + base)) + +(implementation: #export equivalence + (All [a] (Equivalence (Set a))) + + (def: (= (^@ reference [hash _]) sample) + (and (n.= (..size reference) + (..size sample)) + (list.every? (..member? reference) + (..to_list sample))))) + +(implementation: #export hash + (All [a] (Hash (Set a))) + + (def: &equivalence ..equivalence) + + (def: (hash set) + (|> set + ..to_list + (\ (list.hash (..member_hash set)) hash)))) + +(implementation: #export (monoid hash) + (All [a] (-> (Hash a) (Monoid (Set a)))) + + (def: identity (..new hash)) + (def: compose ..union)) + +(def: #export empty? + (All [a] (-> (Set a) Bit)) + (|>> ..size (n.= 0))) + +(def: #export (from_list hash elements) + (All [a] (-> (Hash a) (List a) (Set a))) + (list\fold ..add (..new hash) elements)) + +(def: #export (sub? super sub) + (All [a] (-> (Set a) (Set a) Bit)) + (list.every? (..member? super) (..to_list sub))) + +(def: #export (super? sub super) + (All [a] (-> (Set a) (Set a) Bit)) + (..sub? super sub)) + +(def: #export predicate + (All [a] (-> (Set a) (Predicate a))) + ..member?) diff --git a/stdlib/source/library/lux/data/collection/set/multi.lux b/stdlib/source/library/lux/data/collection/set/multi.lux new file mode 100644 index 000000000..efd266c18 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/set/multi.lux @@ -0,0 +1,158 @@ +## https://en.wikipedia.org/wiki/Multiset +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] + [control + ["." function]] + [math + [number + ["n" nat]]] + [type + [abstract (#+ abstract: :abstraction :representation ^:representation)]]]] + ["." // + [// + ["." list ("#\." fold monoid)] + ["." dictionary (#+ Dictionary)] + [// + ["." maybe]]]]) + +(abstract: #export (Set a) + (Dictionary a Nat) + + (def: #export new + (All [a] (-> (Hash a) (Set a))) + (|>> dictionary.new :abstraction)) + + (def: #export size + (All [a] (-> (Set a) Nat)) + (|>> :representation dictionary.values (list\fold n.+ 0))) + + (def: #export (add multiplicity elem set) + (All [a] (-> Nat a (Set a) (Set a))) + (case multiplicity + 0 set + _ (|> set + :representation + (dictionary.upsert elem 0 (n.+ multiplicity)) + :abstraction))) + + (def: #export (remove multiplicity elem set) + (All [a] (-> Nat a (Set a) (Set a))) + (case multiplicity + 0 set + _ (case (dictionary.get elem (:representation set)) + (#.Some current) + (:abstraction + (if (n.> multiplicity current) + (dictionary.update elem (n.- multiplicity) (:representation set)) + (dictionary.remove elem (:representation set)))) + + #.None + set))) + + (def: #export (multiplicity set elem) + (All [a] (-> (Set a) a Nat)) + (|> set :representation (dictionary.get elem) (maybe.default 0))) + + (def: #export to_list + (All [a] (-> (Set a) (List a))) + (|>> :representation + dictionary.entries + (list\fold (function (_ [elem multiplicity] output) + (list\compose (list.repeat multiplicity elem) output)) + #.Nil))) + + (template [<name> <compose>] + [(def: #export (<name> parameter subject) + (All [a] (-> (Set a) (Set a) (Set a))) + (:abstraction (dictionary.merge_with <compose> (:representation parameter) (:representation subject))))] + + [union n.max] + [sum n.+] + ) + + (def: #export (intersection parameter (^:representation subject)) + (All [a] (-> (Set a) (Set a) (Set a))) + (list\fold (function (_ [elem multiplicity] output) + (..add (n.min (..multiplicity parameter elem) + multiplicity) + elem + output)) + (..new (dictionary.key_hash subject)) + (dictionary.entries subject))) + + (def: #export (difference parameter subject) + (All [a] (-> (Set a) (Set a) (Set a))) + (|> parameter + :representation + dictionary.entries + (list\fold (function (_ [elem multiplicity] output) + (..remove multiplicity elem output)) + subject))) + + (def: #export (sub? reference subject) + (All [a] (-> (Set a) (Set a) Bit)) + (|> subject + :representation + dictionary.entries + (list.every? (function (_ [elem multiplicity]) + (|> elem + (..multiplicity reference) + (n.>= multiplicity)))))) + + (def: #export (support set) + (All [a] (-> (Set a) (//.Set a))) + (let [(^@ set [hash _]) (:representation set)] + (|> set + dictionary.keys + (//.from_list hash)))) + + (implementation: #export equivalence + (All [a] (Equivalence (Set a))) + + (def: (= (^:representation reference) sample) + (and (n.= (dictionary.size reference) + (dictionary.size (:representation sample))) + (|> reference + dictionary.entries + (list.every? (function (_ [elem multiplicity]) + (|> elem + (..multiplicity sample) + (n.= multiplicity)))))))) + + (implementation: #export hash + (All [a] (Hash (Set a))) + + (def: &equivalence ..equivalence) + + (def: (hash (^:representation set)) + (let [[hash _] set] + (list\fold (function (_ [elem multiplicity] acc) + (|> elem (\ hash hash) (n.* multiplicity) (n.+ acc))) + 0 + (dictionary.entries set))))) + ) + +(def: #export (member? set elem) + (All [a] (-> (Set a) a Bit)) + (|> elem (..multiplicity set) (n.> 0))) + +(def: #export empty? + (All [a] (-> (Set a) Bit)) + (|>> ..size (n.= 0))) + +(def: #export (from_list hash subject) + (All [a] (-> (Hash a) (List a) (Set a))) + (list\fold (..add 1) (..new hash) subject)) + +(def: #export (from_set subject) + (All [a] (-> (//.Set a) (Set a))) + (..from_list (//.member_hash subject) + (//.to_list subject))) + +(def: #export super? + (All [a] (-> (Set a) (Set a) Bit)) + (function.flip sub?)) diff --git a/stdlib/source/library/lux/data/collection/set/ordered.lux b/stdlib/source/library/lux/data/collection/set/ordered.lux new file mode 100644 index 000000000..b61bfb546 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/set/ordered.lux @@ -0,0 +1,85 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [order (#+ Order)]] + [data + [collection + ["." list ("#\." fold)] + [dictionary + ["/" ordered]]]] + [type + abstract]]]) + +(abstract: #export (Set a) + (/.Dictionary a a) + + (def: #export new + (All [a] (-> (Order a) (Set a))) + (|>> /.new :abstraction)) + + (def: #export (member? set elem) + (All [a] (-> (Set a) a Bit)) + (/.key? (:representation set) elem)) + + (template [<type> <name> <alias>] + [(def: #export <name> + (All [a] (-> (Set a) <type>)) + (|>> :representation <alias>))] + + [(Maybe a) min /.min] + [(Maybe a) max /.max] + [Nat size /.size] + [Bit empty? /.empty?] + ) + + (def: #export (add elem set) + (All [a] (-> a (Set a) (Set a))) + (|> set :representation (/.put elem elem) :abstraction)) + + (def: #export (remove elem set) + (All [a] (-> a (Set a) (Set a))) + (|> set :representation (/.remove elem) :abstraction)) + + (def: #export to_list + (All [a] (-> (Set a) (List a))) + (|>> :representation /.keys)) + + (def: #export (from_list &order list) + (All [a] (-> (Order a) (List a) (Set a))) + (list\fold add (..new &order) list)) + + (def: #export (union left right) + (All [a] (-> (Set a) (Set a) (Set a))) + (list\fold ..add right (..to_list left))) + + (def: #export (intersection left right) + (All [a] (-> (Set a) (Set a) (Set a))) + (|> (..to_list right) + (list.filter (..member? left)) + (..from_list (get@ #/.&order (:representation right))))) + + (def: #export (difference param subject) + (All [a] (-> (Set a) (Set a) (Set a))) + (|> (..to_list subject) + (list.filter (|>> (..member? param) not)) + (..from_list (get@ #/.&order (:representation subject))))) + + (implementation: #export equivalence + (All [a] (Equivalence (Set a))) + + (def: (= reference sample) + (\ (list.equivalence (\ (:representation reference) &equivalence)) + = (..to_list reference) (..to_list sample)))) + ) + +(def: #export (sub? super sub) + (All [a] (-> (Set a) (Set a) Bit)) + (|> sub + ..to_list + (list.every? (..member? super)))) + +(def: #export (super? sub super) + (All [a] (-> (Set a) (Set a) Bit)) + (sub? super sub)) diff --git a/stdlib/source/library/lux/data/collection/stack.lux b/stdlib/source/library/lux/data/collection/stack.lux new file mode 100644 index 000000000..c81240c29 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/stack.lux @@ -0,0 +1,66 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [functor (#+ Functor)]] + [data + [collection + ["//" list]]] + [type + abstract]]]) + +(abstract: #export (Stack a) + (List a) + + (def: #export empty + Stack + (:abstraction (list))) + + (def: #export size + (All [a] (-> (Stack a) Nat)) + (|>> :representation //.size)) + + (def: #export empty? + (All [a] (-> (Stack a) Bit)) + (|>> :representation //.empty?)) + + (def: #export (peek stack) + (All [a] (-> (Stack a) (Maybe a))) + (case (:representation stack) + #.Nil + #.None + + (#.Cons value _) + (#.Some value))) + + (def: #export (pop stack) + (All [a] (-> (Stack a) (Maybe [a (Stack a)]))) + (case (:representation stack) + #.Nil + #.None + + (#.Cons top stack') + (#.Some [top (:abstraction stack')]))) + + (def: #export (push value stack) + (All [a] (-> a (Stack a) (Stack a))) + (:abstraction (#.Cons value (:representation stack)))) + + (implementation: #export (equivalence super) + (All [a] + (-> (Equivalence a) + (Equivalence (Stack a)))) + + (def: (= reference subject) + (\ (//.equivalence super) = (:representation reference) (:representation subject)))) + + (implementation: #export functor + (Functor Stack) + + (def: (map f value) + (|> value + :representation + (\ //.functor map f) + :abstraction))) + ) diff --git a/stdlib/source/library/lux/data/collection/tree.lux b/stdlib/source/library/lux/data/collection/tree.lux new file mode 100644 index 000000000..f6b3746e7 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/tree.lux @@ -0,0 +1,85 @@ +(.module: + [library + [lux #* + [abstract + [functor (#+ Functor)] + [equivalence (#+ Equivalence)] + [fold (#+ Fold)] + [monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]]] + [data + [collection + ["." list ("#\." monad fold)]]] + [macro + [syntax (#+ syntax:)] + ["." code]]]]) + +(type: #export (Tree a) + {#value a + #children (List (Tree a))}) + +(def: #export (flatten tree) + (All [a] (-> (Tree a) (List a))) + (#.Cons (get@ #value tree) + (list\join (list\map flatten (get@ #children tree))))) + +(def: #export (leaf value) + (All [a] (-> a (Tree a))) + {#value value + #children (list)}) + +(def: #export (branch value children) + (All [a] (-> a (List (Tree a)) (Tree a))) + {#value value + #children children}) + +(type: #rec Tree-Code + [Code (List Tree-Code)]) + +(def: tree^ + (Parser Tree-Code) + (|> (|>> <>.some + <c>.record + (<>.and <c>.any)) + <>.rec + <>.some + <c>.record + (<>.default (list)) + (<>.and <c>.any))) + +(syntax: #export (tree {root tree^}) + {#.doc (doc "Tree literals." + (: (Tree Nat) + (tree 10 + {20 {} + 30 {} + 40 {}})))} + (wrap (list (` (~ (loop [[value children] root] + (` {#value (~ value) + #children (list (~+ (list\map recur children)))}))))))) + +(implementation: #export (equivalence super) + (All [a] (-> (Equivalence a) (Equivalence (Tree a)))) + + (def: (= tx ty) + (and (\ super = (get@ #value tx) (get@ #value ty)) + (\ (list.equivalence (equivalence super)) = (get@ #children tx) (get@ #children ty))))) + +(implementation: #export functor + (Functor Tree) + + (def: (map f fa) + {#value (f (get@ #value fa)) + #children (list\map (map f) + (get@ #children fa))})) + +(implementation: #export fold + (Fold Tree) + + (def: (fold f init tree) + (list\fold (function (_ tree' init') (fold f init' tree')) + (f (get@ #value tree) + init) + (get@ #children tree)))) diff --git a/stdlib/source/library/lux/data/collection/tree/finger.lux b/stdlib/source/library/lux/data/collection/tree/finger.lux new file mode 100644 index 000000000..a3b1be634 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/tree/finger.lux @@ -0,0 +1,108 @@ +(.module: + [library + [lux #* + [abstract + [predicate (#+ Predicate)] + ["." monoid (#+ Monoid)]] + [data + [collection + ["." list ("#\." monoid)]]] + [type + [abstract (#+ abstract: :abstraction :representation)]]]]) + +(abstract: #export (Tree @ t v) + {#monoid (Monoid t) + #tag t + #root (| v + [(Tree @ t v) (Tree @ t v)])} + + (interface: #export (Builder @ t) + (: (All [v] + (-> t v (Tree @ t v))) + leaf) + (: (All [v] + (-> (Tree @ t v) + (Tree @ t v) + (Tree @ t v))) + branch)) + + (template [<name> <tag> <output>] + [(def: #export <name> + (All [@ t v] (-> (Tree @ t v) <output>)) + (|>> :representation (get@ <tag>)))] + + [tag #tag t] + [root #root (Either v [(Tree @ t v) (Tree @ t v)])] + ) + + (implementation: #export (builder monoid) + (All [t] (Ex [@] (-> (Monoid t) (Builder @ t)))) + + (def: (leaf tag value) + (:abstraction + {#monoid monoid + #tag tag + #root (0 #0 value)})) + + (def: (branch left right) + (:abstraction + {#monoid monoid + #tag (\ monoid compose (..tag left) (..tag right)) + #root (0 #1 [left right])}))) + + (def: #export (value tree) + (All [@ t v] (-> (Tree @ t v) v)) + (case (get@ #root (:representation tree)) + (0 #0 value) + value + + (0 #1 [left right]) + (value left))) + + (def: #export (tags tree) + (All [@ t v] (-> (Tree @ t v) (List t))) + (case (get@ #root (:representation tree)) + (0 #0 value) + (list (get@ #tag (:representation tree))) + + (0 #1 [left right]) + (list\compose (tags left) + (tags right)))) + + (def: #export (values tree) + (All [@ t v] (-> (Tree @ t v) (List v))) + (case (get@ #root (:representation tree)) + (0 #0 value) + (list value) + + (0 #1 [left right]) + (list\compose (values left) + (values right)))) + + (def: #export (search predicate tree) + (All [@ t v] (-> (Predicate t) (Tree @ t v) (Maybe v))) + (let [[monoid tag root] (:representation tree)] + (if (predicate tag) + (let [(^open "tag//.") monoid] + (loop [_tag tag//identity + _node root] + (case _node + (0 #0 value) + (#.Some value) + + (0 #1 [left right]) + (let [shifted_tag (tag//compose _tag (..tag left))] + (if (predicate shifted_tag) + (recur _tag (get@ #root (:representation left))) + (recur shifted_tag (get@ #root (:representation right)))))))) + #.None))) + ) + +(def: #export (found? predicate tree) + (All [@ t v] (-> (Predicate t) (Tree @ t v) Bit)) + (case (..search predicate tree) + (#.Some _) + true + + #.None + false)) diff --git a/stdlib/source/library/lux/data/collection/tree/zipper.lux b/stdlib/source/library/lux/data/collection/tree/zipper.lux new file mode 100644 index 000000000..bb36e3e38 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/tree/zipper.lux @@ -0,0 +1,318 @@ +(.module: + [library + [lux #* + ["@" target] + [abstract + [functor (#+ Functor)] + [comonad (#+ CoMonad)] + [monad (#+ do)] + [equivalence (#+ Equivalence)]] + [data + ["." product] + ["." maybe ("#\." monad)] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold monoid)]]]]] + ["." // (#+ Tree) ("#\." functor)]) + +(type: (Family Zipper a) + {#parent (Zipper a) + #lefts (List (Tree a)) + #rights (List (Tree a))}) + +(type: #export (Zipper a) + {#.doc "Tree zippers, for easy navigation and editing of trees."} + {#family (Maybe (Family Zipper a)) + #node (Tree a)}) + +(implementation: #export (equivalence super) + (All [a] + (-> (Equivalence a) + (Equivalence (Zipper a)))) + + (def: (= reference sample) + (let [== ($_ product.equivalence + (maybe.equivalence + ($_ product.equivalence + = + (list.equivalence (//.equivalence super)) + (list.equivalence (//.equivalence super)))) + (//.equivalence super))] + (== reference sample)))) + +(def: #export (zip tree) + (All [a] (-> (Tree a) (Zipper a))) + {#family #.None + #node tree}) + +(def: #export unzip + (All [a] (-> (Zipper a) (Tree a))) + (get@ #node)) + +(def: #export value + (All [a] (-> (Zipper a) a)) + (get@ [#node #//.value])) + +(def: #export set + (All [a] (-> a (Zipper a) (Zipper a))) + (set@ [#node #//.value])) + +(def: #export update + (All [a] (-> (-> a a) (Zipper a) (Zipper a))) + (update@ [#node #//.value])) + +(def: children + (All [a] (-> (Zipper a) (List (Tree a)))) + (get@ [#node #//.children])) + +(def: #export leaf? + (All [a] (-> (Zipper a) Bit)) + (|>> ..children list.empty?)) + +(def: #export branch? + (All [a] (-> (Zipper a) Bit)) + (|>> ..leaf? not)) + +(def: #export (start? zipper) + (All [a] (-> (Zipper a) Bit)) + (case (get@ #family zipper) + #.None + true + + _ + false)) + +(def: #export (down zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (..children zipper) + #.Nil + #.None + + (#.Cons head tail) + (#.Some {#family (#.Some {#parent (set@ [#node #//.children] (list) zipper) + #lefts #.Nil + #rights tail}) + #node head}))) + +(def: #export (up zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (do maybe.monad + [family (get@ #family zipper)] + (wrap (let [(^slots [#parent #lefts #rights]) family] + (for {@.old + (update@ #node (: (-> (Tree ($ 0)) (Tree ($ 0))) + (set@ #//.children (list\compose (list.reverse lefts) + (#.Cons (get@ #node zipper) + rights)))) + parent)} + (set@ [#node #//.children] + (list\compose (list.reverse lefts) + (#.Cons (get@ #node zipper) + rights)) + parent)))))) + +(template [<one> <all> <side> <op-side>] + [(def: #export (<one> zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (get@ #family zipper) + (#.Some family) + (case (get@ <side> family) + (#.Cons next side') + (#.Some (for {@.old + {#family (#.Some (|> family + (set@ <side> side') + (update@ <op-side> (|>> (#.Cons (get@ #node zipper)))))) + #node next}} + (let [move (: (All [a] (-> (List (Tree a)) (Zipper a) (Family Zipper a) (Family Zipper a))) + (function (_ side' zipper) + (|>> (set@ <side> side') + (update@ <op-side> (|>> (#.Cons (get@ #node zipper)))))))] + {#family (#.Some (move side' zipper family)) + #node next}))) + + #.Nil + #.None) + + #.None + #.None)) + + (def: #export (<all> zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (get@ #family zipper) + #.None + #.None + + (#.Some family) + (case (list.reverse (get@ <side> family)) + #.Nil + #.None + + (#.Cons last prevs) + (#.Some (for {@.old {#family (#.Some (|> family + (set@ <side> #.Nil) + (update@ <op-side> (|>> (#.Cons (get@ #node zipper)) + (list\compose prevs))))) + #node last}} + (let [move (: (All [a] (-> (List (Tree a)) (Zipper a) (Family Zipper a) (Family Zipper a))) + (function (_ prevs zipper) + (|>> (set@ <side> #.Nil) + (update@ <op-side> (|>> (#.Cons (get@ #node zipper)) + (list\compose prevs))))))] + {#family (#.Some (move prevs zipper family)) + #node last}))))))] + + [right rightmost #rights #lefts] + [left leftmost #lefts #rights] + ) + +(def: #export (next zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (..down zipper) + (#.Some forward) + (#.Some forward) + + #.None + (loop [@ zipper] + (case (..right @) + (#.Some forward) + (#.Some forward) + + #.None + (do maybe.monad + [@ (..up @)] + (recur @)))))) + +(def: (bottom zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (..right zipper) + (#.Some forward) + (bottom forward) + + #.None + (case (..down zipper) + (#.Some forward) + (bottom forward) + + #.None + zipper))) + +(def: #export (previous zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (..left zipper) + #.None + (..up zipper) + + (#.Some backward) + (#.Some (case (..down backward) + (#.Some then) + (..bottom then) + + #.None + backward)))) + +(template [<name> <move>] + [(def: #export (<name> zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (<move> zipper) + #.None + #.None + + (#.Some @) + (loop [@ @] + (case (<move> @) + #.None + (#.Some @) + + (#.Some @) + (recur @)))))] + + [end ..next] + [start ..previous] + ) + +(def: #export (end? zipper) + (All [a] (-> (Zipper a) Bit)) + (case (..end zipper) + #.None + true + + (#.Some _) + false)) + +(def: #export (interpose value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #//.children] + (|>> (//.branch value) list) + zipper)) + +(def: #export (adopt value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #//.children] + (|>> (#.Cons (//.leaf value))) + zipper)) + +(def: #export (remove zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (do maybe.monad + [family (get@ #family zipper)] + (case (get@ #lefts family) + #.Nil + (wrap (set@ [#node #//.children] + (get@ #rights family) + (get@ #parent family))) + + (#.Cons next side) + (wrap (|> zipper + (set@ #family (|> family + (set@ #lefts side) + #.Some)) + (set@ #node next)))))) + +(template [<name> <side>] + [(def: #export (<name> value zipper) + (All [a] (-> a (Zipper a) (Maybe (Zipper a)))) + (case (get@ #family zipper) + #.None + #.None + + (#.Some family) + (#.Some (set@ #family + (#.Some (update@ <side> (|>> (#.Cons (//.leaf value))) family)) + zipper))))] + + [insert-left #lefts] + [insert-right #rights] + ) + +(implementation: #export functor + (Functor Zipper) + + (def: (map f (^slots [#family #node])) + {#family (maybe\map (function (_ (^slots [#parent #lefts #rights])) + {#parent (map f parent) + #lefts (list\map (//\map f) lefts) + #rights (list\map (//\map f) rights)}) + family) + #node (//\map f node)})) + +(implementation: #export comonad + (CoMonad Zipper) + + (def: &functor ..functor) + + (def: unwrap (get@ [#node #//.value])) + + (def: (split (^slots [#family #node])) + (let [tree-splitter (: (All [a] (-> (Tree a) (Tree (Zipper a)))) + (function (tree-splitter tree) + {#//.value (..zip tree) + #//.children (|> tree + (get@ #//.children) + (list\map tree-splitter))}))] + {#family (maybe\map (function (_ (^slots [#parent #lefts #rights])) + {#parent (split parent) + #lefts (list\map tree-splitter lefts) + #rights (list\map tree-splitter rights)}) + family) + #node (tree-splitter node)}))) diff --git a/stdlib/source/library/lux/data/color.lux b/stdlib/source/library/lux/data/color.lux new file mode 100644 index 000000000..72847c91d --- /dev/null +++ b/stdlib/source/library/lux/data/color.lux @@ -0,0 +1,425 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [monoid (#+ Monoid)] + ["." hash (#+ Hash)]] + [data + [collection + ["." list ("#\." functor)]]] + ["." math + [number + ["n" nat] + ["f" frac] + ["." int] + ["." rev ("#\." interval)] + ["." i64]]] + [type + abstract]]]) + +(def: rgb 256) +(def: top (dec rgb)) + +(def: rgb_factor (|> top .int int.frac)) + +(def: down + (-> Nat Frac) + (|>> .int int.frac (f./ rgb_factor))) + +(def: up + (-> Frac Nat) + (|>> (f.* rgb_factor) f.int .nat)) + +(type: #export RGB + {#red Nat + #green Nat + #blue Nat}) + +(type: #export HSL + [Frac Frac Frac]) + +(type: #export CMYK + {#cyan Frac + #magenta Frac + #yellow Frac + #key Frac}) + +(type: #export HSB + [Frac Frac Frac]) + +(abstract: #export Color + RGB + + (def: #export (from_rgb [red green blue]) + (-> RGB Color) + (:abstraction {#red (n.% ..rgb red) + #green (n.% ..rgb green) + #blue (n.% ..rgb blue)})) + + (def: #export to_rgb + (-> Color RGB) + (|>> :representation)) + + (implementation: #export equivalence + (Equivalence Color) + + (def: (= reference sample) + (let [[rR gR bR] (:representation reference) + [rS gS bS] (:representation sample)] + (and (n.= rR rS) + (n.= gR gS) + (n.= bR bS))))) + + (implementation: #export hash + (Hash Color) + + (def: &equivalence ..equivalence) + + (def: (hash value) + (let [[r g b] (:representation value)] + ($_ i64.or + (i64.left_shift 16 r) + (i64.left_shift 8 g) + b)))) + + (def: #export black + (..from_rgb {#red 0 + #green 0 + #blue 0})) + + (def: #export white + (..from_rgb {#red ..top + #green ..top + #blue ..top})) + + (implementation: #export addition + (Monoid Color) + + (def: identity ..black) + + (def: (compose left right) + (let [[lR lG lB] (:representation left) + [rR rG rB] (:representation right)] + (:abstraction {#red (n.max lR rR) + #green (n.max lG rG) + #blue (n.max lB rB)})))) + + (def: (complement' value) + (-> Nat Nat) + (|> ..top (n.- value))) + + (def: #export (complement color) + (-> Color Color) + (let [[red green blue] (:representation color)] + (:abstraction {#red (complement' red) + #green (complement' green) + #blue (complement' blue)}))) + + (implementation: #export subtraction + (Monoid Color) + + (def: identity ..white) + + (def: (compose left right) + (let [[lR lG lB] (:representation (..complement left)) + [rR rG rB] (:representation right)] + (:abstraction {#red (n.min lR rR) + #green (n.min lG rG) + #blue (n.min lB rB)})))) + ) + +(def: #export (to_hsl color) + (-> Color HSL) + (let [[red green blue] (to_rgb color) + red (..down red) + green (..down green) + blue (..down blue) + max ($_ f.max red green blue) + min ($_ f.min red green blue) + luminance (|> (f.+ max min) (f./ +2.0))] + (if (f.= max min) + ## Achromatic + [+0.0 + +0.0 + luminance] + ## Chromatic + (let [diff (|> max (f.- min)) + saturation (|> diff + (f./ (if (f.> +0.5 luminance) + (|> +2.0 (f.- max) (f.- min)) + (|> max (f.+ min))))) + hue' (cond (f.= red max) + (|> green (f.- blue) (f./ diff) + (f.+ (if (f.< blue green) +6.0 +0.0))) + + (f.= green max) + (|> blue (f.- red) (f./ diff) + (f.+ +2.0)) + + ## (f.= blue max) + (|> red (f.- green) (f./ diff) + (f.+ +4.0)))] + [(|> hue' (f./ +6.0)) + saturation + luminance])))) + +(def: (hue_to_rgb p q t) + (-> Frac Frac Frac Frac) + (let [t (cond (f.< +0.0 t) (f.+ +1.0 t) + (f.> +1.0 t) (f.- +1.0 t) + ## else + t) + f2/3 (f./ +3.0 +2.0)] + (cond (f.< (f./ +6.0 +1.0) t) + (|> q (f.- p) (f.* +6.0) (f.* t) (f.+ p)) + + (f.< (f./ +2.0 +1.0) t) + q + + (f.< f2/3 t) + (|> q (f.- p) (f.* (|> f2/3 (f.- t))) (f.* +6.0) (f.+ p)) + + ## else + p))) + +(def: #export (from_hsl [hue saturation luminance]) + (-> HSL Color) + (if (f.= +0.0 saturation) + ## Achromatic + (let [intensity (..up luminance)] + (from_rgb {#red intensity + #green intensity + #blue intensity})) + ## Chromatic + (let [q (if (f.< +0.5 luminance) + (|> saturation (f.+ +1.0) (f.* luminance)) + (|> luminance (f.+ saturation) (f.- (f.* saturation luminance)))) + p (|> luminance (f.* +2.0) (f.- q)) + third (|> +1.0 (f./ +3.0))] + (from_rgb {#red (..up (|> hue (f.+ third) (hue_to_rgb p q))) + #green (..up (|> hue (hue_to_rgb p q))) + #blue (..up (|> hue (f.- third) (hue_to_rgb p q)))})))) + +(def: #export (to_hsb color) + (-> Color HSB) + (let [[red green blue] (to_rgb color) + red (..down red) + green (..down green) + blue (..down blue) + max ($_ f.max red green blue) + min ($_ f.min red green blue) + brightness max + diff (|> max (f.- min)) + saturation (if (f.= +0.0 max) + +0.0 + (|> diff (f./ max)))] + (if (f.= max min) + ## Achromatic + [+0.0 saturation brightness] + ## Chromatic + (let [hue (cond (f.= red max) + (|> green (f.- blue) (f./ diff) + (f.+ (if (f.< blue green) +6.0 +0.0))) + + (f.= green max) + (|> blue (f.- red) (f./ diff) + (f.+ +2.0)) + + ## (f.= blue max) + (|> red (f.- green) (f./ diff) + (f.+ +4.0)))] + [(|> hue (f./ +6.0)) + saturation + brightness])))) + +(def: #export (from_hsb [hue saturation brightness]) + (-> HSB Color) + (let [hue (|> hue (f.* +6.0)) + i (math.floor hue) + f (|> hue (f.- i)) + p (|> +1.0 (f.- saturation) (f.* brightness)) + q (|> +1.0 (f.- (f.* f saturation)) (f.* brightness)) + t (|> +1.0 (f.- (|> +1.0 (f.- f) (f.* saturation))) (f.* brightness)) + v brightness + mod (|> i (f.% +6.0) f.int .nat) + red (case mod 0 v 1 q 2 p 3 p 4 t 5 v _ (undefined)) + green (case mod 0 t 1 v 2 v 3 q 4 p 5 p _ (undefined)) + blue (case mod 0 p 1 p 2 t 3 v 4 v 5 q _ (undefined))] + (from_rgb {#red (..up red) + #green (..up green) + #blue (..up blue)}))) + +(def: #export (to_cmyk color) + (-> Color CMYK) + (let [[red green blue] (to_rgb color) + red (..down red) + green (..down green) + blue (..down blue) + key (|> +1.0 (f.- ($_ f.max red green blue))) + f (if (f.< +1.0 key) + (|> +1.0 (f./ (|> +1.0 (f.- key)))) + +0.0) + cyan (|> +1.0 (f.- red) (f.- key) (f.* f)) + magenta (|> +1.0 (f.- green) (f.- key) (f.* f)) + yellow (|> +1.0 (f.- blue) (f.- key) (f.* f))] + {#cyan cyan + #magenta magenta + #yellow yellow + #key key})) + +(def: #export (from_cmyk [cyan magenta yellow key]) + (-> CMYK Color) + (if (f.= +1.0 key) + (from_rgb {#red 0 + #green 0 + #blue 0}) + (let [red (|> (|> +1.0 (f.- cyan)) + (f.* (|> +1.0 (f.- key)))) + green (|> (|> +1.0 (f.- magenta)) + (f.* (|> +1.0 (f.- key)))) + blue (|> (|> +1.0 (f.- yellow)) + (f.* (|> +1.0 (f.- key))))] + (from_rgb {#red (..up red) + #green (..up green) + #blue (..up blue)})))) + +(def: (normalize ratio) + (-> Frac Frac) + (cond (f.> +1.0 ratio) + (f.% +1.0 ratio) + + (f.< +0.0 ratio) + (|> ratio (f.% +1.0) (f.+ +1.0)) + + ## else + ratio)) + +(def: #export (interpolate ratio end start) + (-> Frac Color Color Color) + (let [dS (..normalize ratio) + dE (|> +1.0 (f.- dS)) + interpolate' (: (-> Nat Nat Nat) + (function (_ end start) + (|> (|> start .int int.frac (f.* dS)) + (f.+ (|> end .int int.frac (f.* dE))) + f.int + .nat))) + [redS greenS blueS] (to_rgb start) + [redE greenE blueE] (to_rgb end)] + (from_rgb {#red (interpolate' redE redS) + #green (interpolate' greenE greenS) + #blue (interpolate' blueE blueS)}))) + +(template [<name> <target>] + [(def: #export (<name> ratio color) + (-> Frac Color Color) + (..interpolate ratio <target> color))] + + [darker black] + [brighter white] + ) + +(template [<name> <op>] + [(def: #export (<name> ratio color) + (-> Frac Color Color) + (let [[hue saturation luminance] (to_hsl color)] + (from_hsl [hue + (|> saturation + (f.* (|> +1.0 (<op> (..normalize ratio)))) + (f.min +1.0)) + luminance])))] + + [saturate f.+] + [de_saturate f.-] + ) + +(def: #export (gray_scale color) + (-> Color Color) + (let [[_ _ luminance] (to_hsl color)] + (from_hsl [+0.0 + +0.0 + luminance]))) + +(template [<name> <1> <2>] + [(def: #export (<name> color) + (-> Color [Color Color Color]) + (let [[hue saturation luminance] (to_hsl color)] + [color + (from_hsl [(|> hue (f.+ <1>) ..normalize) + saturation + luminance]) + (from_hsl [(|> hue (f.+ <2>) ..normalize) + saturation + luminance])]))] + + [triad (|> +1.0 (f./ +3.0)) (|> +2.0 (f./ +3.0))] + [clash (|> +1.0 (f./ +4.0)) (|> +3.0 (f./ +4.0))] + [split_complement (|> +1.0 (f./ +5.0)) (|> +3.0 (f./ +5.0))] + ) + +(template [<name> <1> <2> <3>] + [(def: #export (<name> color) + (-> Color [Color Color Color Color]) + (let [[hue saturation luminance] (to_hsb color)] + [color + (from_hsb [(|> hue (f.+ <1>) ..normalize) + saturation + luminance]) + (from_hsb [(|> hue (f.+ <2>) ..normalize) + saturation + luminance]) + (from_hsb [(|> hue (f.+ <3>) ..normalize) + saturation + luminance])]))] + + [square (|> +1.0 (f./ +4.0)) (|> +2.0 (f./ +4.0)) (|> +3.0 (f./ +4.0))] + [tetradic (|> +2.0 (f./ +12.0)) (|> +6.0 (f./ +12.0)) (|> +8.0 (f./ +12.0))] + ) + +(type: #export Spread + Frac) + +(type: #export Palette + (-> Spread Nat Color (List Color))) + +(def: #export (analogous spread variations color) + (-> Spread Nat Color (List Color)) + (let [[hue saturation brightness] (to_hsb color) + spread (..normalize spread)] + (list\map (function (_ idx) + (from_hsb [(|> idx inc .int int.frac (f.* spread) (f.+ hue) ..normalize) + saturation + brightness])) + (list.indices variations)))) + +(def: #export (monochromatic spread variations color) + (-> Spread Nat Color (List Color)) + (let [[hue saturation brightness] (to_hsb color) + spread (..normalize spread)] + (|> (list.indices variations) + (list\map (|>> inc .int int.frac + (f.* spread) + (f.+ brightness) + ..normalize + [hue saturation] + from_hsb))))) + +(type: #export Alpha + Rev) + +(def: #export transparent + Alpha + rev\bottom) + +(def: #export translucent + Alpha + .5) + +(def: #export opaque + Alpha + rev\top) + +(type: #export Pigment + {#color Color + #alpha Alpha}) diff --git a/stdlib/source/library/lux/data/color/named.lux b/stdlib/source/library/lux/data/color/named.lux new file mode 100644 index 000000000..a9a9ab4ab --- /dev/null +++ b/stdlib/source/library/lux/data/color/named.lux @@ -0,0 +1,156 @@ +(.module: + [library + [lux #* + [math + [number (#+ hex)]]]] + ["." // (#+ Color)]) + +(template [<red> <green> <blue> <name>] + [(def: #export <name> + Color + (//.from_rgb {#//.red (hex <red>) + #//.green (hex <green>) + #//.blue (hex <blue>)}))] + + ["F0" "F8" "FF" alice_blue] + ["FA" "EB" "D7" antique_white] + ["00" "FF" "FF" aqua] + ["7F" "FF" "D4" aquamarine] + ["F0" "FF" "FF" azure] + ["F5" "F5" "DC" beige] + ["FF" "E4" "C4" bisque] + ["00" "00" "00" black] + ["FF" "EB" "CD" blanched_almond] + ["00" "00" "FF" blue] + ["8A" "2B" "E2" blue_violet] + ["A5" "2A" "2A" brown] + ["DE" "B8" "87" burly_wood] + ["5F" "9E" "A0" cadet_blue] + ["7F" "FF" "00" chartreuse] + ["D2" "69" "1E" chocolate] + ["FF" "7F" "50" coral] + ["64" "95" "ED" cornflower_blue] + ["FF" "F8" "DC" cornsilk] + ["DC" "14" "3C" crimson] + ["00" "FF" "FF" cyan] + ["00" "00" "8B" dark_blue] + ["00" "8B" "8B" dark_cyan] + ["B8" "86" "0B" dark_goldenrod] + ["A9" "A9" "A9" dark_gray] + ["00" "64" "00" dark_green] + ["BD" "B7" "6B" dark_khaki] + ["8B" "00" "8B" dark_magenta] + ["55" "6B" "2F" dark_olive_green] + ["FF" "8C" "00" dark_orange] + ["99" "32" "CC" dark_orchid] + ["8B" "00" "00" dark_red] + ["E9" "96" "7A" dark_salmon] + ["8F" "BC" "8F" dark_sea_green] + ["48" "3D" "8B" dark_slate_blue] + ["2F" "4F" "4F" dark_slate_gray] + ["00" "CE" "D1" dark_turquoise] + ["94" "00" "D3" dark_violet] + ["FF" "14" "93" deep_pink] + ["00" "BF" "FF" deep_sky_blue] + ["69" "69" "69" dim_gray] + ["1E" "90" "FF" dodger_blue] + ["B2" "22" "22" fire_brick] + ["FF" "FA" "F0" floral_white] + ["22" "8B" "22" forest_green] + ["FF" "00" "FF" fuchsia] + ["DC" "DC" "DC" gainsboro] + ["F8" "F8" "FF" ghost_white] + ["FF" "D7" "00" gold] + ["DA" "A5" "20" goldenrod] + ["80" "80" "80" gray] + ["00" "80" "00" green] + ["AD" "FF" "2F" green_yellow] + ["F0" "FF" "F0" honey_dew] + ["FF" "69" "B4" hot_pink] + ["CD" "5C" "5C" indian_red] + ["4B" "00" "82" indigo] + ["FF" "FF" "F0" ivory] + ["F0" "E6" "8C" khaki] + ["E6" "E6" "FA" lavender] + ["FF" "F0" "F5" lavender_blush] + ["7C" "FC" "00" lawn_green] + ["FF" "FA" "CD" lemon_chiffon] + ["AD" "D8" "E6" light_blue] + ["F0" "80" "80" light_coral] + ["E0" "FF" "FF" light_cyan] + ["FA" "FA" "D2" light_goldenrod_yellow] + ["D3" "D3" "D3" light_gray] + ["90" "EE" "90" light_green] + ["FF" "B6" "C1" light_pink] + ["FF" "A0" "7A" light_salmon] + ["20" "B2" "AA" light_sea_green] + ["87" "CE" "FA" light_sky_blue] + ["77" "88" "99" light_slate_gray] + ["B0" "C4" "DE" light_steel_blue] + ["FF" "FF" "E0" light_yellow] + ["00" "FF" "00" lime] + ["32" "CD" "32" lime_green] + ["FA" "F0" "E6" linen] + ["FF" "00" "FF" magenta] + ["80" "00" "00" maroon] + ["66" "CD" "AA" medium_aquamarine] + ["00" "00" "CD" medium_blue] + ["BA" "55" "D3" medium_orchid] + ["93" "70" "DB" medium_purple] + ["3C" "B3" "71" medium_sea_green] + ["7B" "68" "EE" medium_slate_blue] + ["00" "FA" "9A" medium_spring_green] + ["48" "D1" "CC" medium_turquoise] + ["C7" "15" "85" medium_violet_red] + ["19" "19" "70" midnight_blue] + ["F5" "FF" "FA" mint_cream] + ["FF" "E4" "E1" misty_rose] + ["FF" "E4" "B5" moccasin] + ["FF" "DE" "AD" navajo_white] + ["00" "00" "80" navy] + ["FD" "F5" "E6" old_lace] + ["80" "80" "00" olive] + ["6B" "8E" "23" olive_drab] + ["FF" "A5" "00" orange] + ["FF" "45" "00" orange_red] + ["DA" "70" "D6" orchid] + ["EE" "E8" "AA" pale_goldenrod] + ["98" "FB" "98" pale_green] + ["AF" "EE" "EE" pale_turquoise] + ["DB" "70" "93" pale_violet_red] + ["FF" "EF" "D5" papaya_whip] + ["FF" "DA" "B9" peach_puff] + ["CD" "85" "3F" peru] + ["FF" "C0" "CB" pink] + ["DD" "A0" "DD" plum] + ["B0" "E0" "E6" powder_blue] + ["80" "00" "80" purple] + ["66" "33" "99" rebecca_purple] + ["FF" "00" "00" red] + ["BC" "8F" "8F" rosy_brown] + ["41" "69" "E1" royal_blue] + ["8B" "45" "13" saddle_brown] + ["FA" "80" "72" salmon] + ["F4" "A4" "60" sandy_brown] + ["2E" "8B" "57" sea_green] + ["FF" "F5" "EE" sea_shell] + ["A0" "52" "2D" sienna] + ["C0" "C0" "C0" silver] + ["87" "CE" "EB" sky_blue] + ["6A" "5A" "CD" slate_blue] + ["70" "80" "90" slate_gray] + ["FF" "FA" "FA" snow] + ["00" "FF" "7F" spring_green] + ["46" "82" "B4" steel_blue] + ["D2" "B4" "8C" tan] + ["00" "80" "80" teal] + ["D8" "BF" "D8" thistle] + ["FF" "63" "47" tomato] + ["40" "E0" "D0" turquoise] + ["EE" "82" "EE" violet] + ["F5" "DE" "B3" wheat] + ["FF" "FF" "FF" white] + ["F5" "F5" "F5" white_smoke] + ["FF" "FF" "00" yellow] + ["9A" "CD" "32" yellow_green] + ) diff --git a/stdlib/source/library/lux/data/format/binary.lux b/stdlib/source/library/lux/data/format/binary.lux new file mode 100644 index 000000000..7103f7d9d --- /dev/null +++ b/stdlib/source/library/lux/data/format/binary.lux @@ -0,0 +1,292 @@ +(.module: + [library + [lux (#- and or nat int rev list type) + [type (#+ :share)] + [abstract + [monoid (#+ Monoid)] + [monad (#+ Monad do)] + [equivalence (#+ Equivalence)]] + [control + [pipe (#+ case>)] + ["." function] + ["." try (#+ Try)] + ["<>" parser ("#\." monad) + ["/" binary (#+ Offset Size Parser)]]] + [data + ["." product] + ["." binary (#+ Binary)] + [text + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." list] + ["." row (#+ Row) ("#\." functor)] + ["." set (#+ Set)]]] + [math + [number + ["." i64] + ["n" nat] + ["." frac]]]]]) + +(def: mask + (-> Size (I64 Any)) + (|>> (n.* i64.bits_per_byte) i64.mask)) + +(type: #export Mutation + (-> [Offset Binary] [Offset Binary])) + +(type: #export Specification + [Size Mutation]) + +(def: #export no_op + Specification + [0 function.identity]) + +(def: #export (instance [size mutation]) + (-> Specification Binary) + (|> size binary.create [0] mutation product.right)) + +(implementation: #export monoid + (Monoid Specification) + + (def: identity + ..no_op) + + (def: (compose [sizeL mutL] [sizeR mutR]) + [(n.+ sizeL sizeR) + (|>> mutL mutR)])) + +(type: #export (Writer a) + (-> a Specification)) + +(def: #export (run writer value) + (All [a] (-> (Writer a) a Binary)) + (..instance (writer value))) + +(template [<name> <size> <write>] + [(def: #export <name> + (Writer (I64 Any)) + (function (_ value) + [<size> + (function (_ [offset binary]) + [(n.+ <size> offset) + (|> binary + (<write> offset value) + try.assume)])]))] + + [bits/8 /.size/8 binary.write/8] + [bits/16 /.size/16 binary.write/16] + [bits/32 /.size/32 binary.write/32] + [bits/64 /.size/64 binary.write/64] + ) + +(def: #export (or left right) + (All [l r] (-> (Writer l) (Writer r) (Writer (| l r)))) + (function (_ altV) + (case altV + (^template [<number> <tag> <writer>] + [(<tag> caseV) + (let [[caseS caseT] (<writer> caseV)] + [(.inc caseS) + (function (_ [offset binary]) + (|> binary + (binary.write/8 offset <number>) + try.assume + [(.inc offset)] + caseT))])]) + ([0 #.Left left] + [1 #.Right right]) + ))) + +(def: #export (and pre post) + (All [a b] (-> (Writer a) (Writer b) (Writer [a b]))) + (function (_ [preV postV]) + (\ ..monoid compose (pre preV) (post postV)))) + +(def: #export (rec body) + (All [a] (-> (-> (Writer a) (Writer a)) (Writer a))) + (function (recur value) + (body recur value))) + +(def: #export any + (Writer Any) + (function.constant ..no_op)) + +(def: #export bit + (Writer Bit) + (|>> (case> #0 0 #1 1) ..bits/8)) + +(template [<name> <type>] + [(def: #export <name> (Writer <type>) ..bits/64)] + + [nat Nat] + [int Int] + [rev Rev] + ) + +(def: #export frac + (Writer Frac) + (|>> frac.to_bits ..bits/64)) + +(def: #export (segment size) + (-> Nat (Writer Binary)) + (function (_ value) + [size + (function (_ [offset binary]) + [(n.+ size offset) + (try.assume + (binary.copy (n.min size (binary.size value)) + 0 + value + offset + binary))])])) + +(template [<name> <bits> <size> <write>] + [(def: #export <name> + (Writer Binary) + (let [mask (..mask <size>)] + (function (_ value) + (let [size (|> value binary.size (i64.and mask)) + size' (n.+ <size> size)] + [size' + (function (_ [offset binary]) + [(n.+ size' offset) + (try.assume + (do try.monad + [_ (<write> offset size binary)] + (binary.copy size 0 value (n.+ <size> offset) binary)))])]))))] + + [binary/8 ..bits/8 /.size/8 binary.write/8] + [binary/16 ..bits/16 /.size/16 binary.write/16] + [binary/32 ..bits/32 /.size/32 binary.write/32] + [binary/64 ..bits/64 /.size/64 binary.write/64] + ) + +(template [<name> <binary>] + [(def: #export <name> + (Writer Text) + (|>> (\ utf8.codec encode) <binary>))] + + [utf8/8 ..binary/8] + [utf8/16 ..binary/16] + [utf8/32 ..binary/32] + [utf8/64 ..binary/64] + ) + +(def: #export text ..utf8/64) + +(template [<name> <size> <write>] + [(def: #export (<name> valueW) + (All [v] (-> (Writer v) (Writer (Row v)))) + (function (_ value) + (let [original_count (row.size value) + capped_count (i64.and (..mask <size>) + original_count) + value (if (n.= original_count capped_count) + value + (|> value row.to_list (list.take capped_count) row.from_list)) + (^open "specification\.") ..monoid + [size mutation] (|> value + (row\map valueW) + (\ row.fold fold + (function (_ post pre) + (specification\compose pre post)) + specification\identity))] + [(n.+ <size> size) + (function (_ [offset binary]) + (try.assume + (do try.monad + [_ (<write> offset capped_count binary)] + (wrap (mutation [(n.+ <size> offset) binary])))))])))] + + [row/8 /.size/8 binary.write/8] + [row/16 /.size/16 binary.write/16] + [row/32 /.size/32 binary.write/32] + [row/64 /.size/64 binary.write/64] + ) + +(def: #export maybe + (All [a] (-> (Writer a) (Writer (Maybe a)))) + (..or ..any)) + +(def: #export (list value) + (All [a] (-> (Writer a) (Writer (List a)))) + (..rec + (|>> (..and value) + (..or ..any)))) + +(def: #export (set value) + (All [a] (-> (Writer a) (Writer (Set a)))) + (|>> set.to_list (..list value))) + +(def: #export name + (Writer Name) + (..and ..text ..text)) + +(def: #export type + (Writer Type) + (..rec + (function (_ recur) + (let [pair (..and recur recur) + indexed ..nat + quantified (..and (..list recur) recur)] + (function (_ altV) + (case altV + (^template [<number> <tag> <writer>] + [(<tag> caseV) + (let [[caseS caseT] (<writer> caseV)] + [(.inc caseS) + (function (_ [offset binary]) + (|> binary + (binary.write/8 offset <number>) + try.assume + [(.inc offset)] + caseT))])]) + ([0 #.Primitive (..and ..text (..list recur))] + [1 #.Sum pair] + [2 #.Product pair] + [3 #.Function pair] + [4 #.Parameter indexed] + [5 #.Var indexed] + [6 #.Ex indexed] + [7 #.UnivQ quantified] + [8 #.ExQ quantified] + [9 #.Apply pair] + [10 #.Named (..and ..name recur)]) + )))))) + +(def: #export location + (Writer Location) + ($_ ..and ..text ..nat ..nat)) + +(def: #export code + (Writer Code) + (..rec + (function (_ recur) + (let [sequence (..list recur)] + (..and ..location + (function (_ altV) + (case altV + (^template [<number> <tag> <writer>] + [(<tag> caseV) + (let [[caseS caseT] (<writer> caseV)] + [(.inc caseS) + (function (_ [offset binary]) + (|> binary + (binary.write/8 offset <number>) + try.assume + [(.inc offset)] + caseT))])]) + ([0 #.Bit ..bit] + [1 #.Nat ..nat] + [2 #.Int ..int] + [3 #.Rev ..rev] + [4 #.Frac ..frac] + [5 #.Text ..text] + [6 #.Identifier ..name] + [7 #.Tag ..name] + [8 #.Form sequence] + [9 #.Tuple sequence] + [10 #.Record (..list (..and recur recur))]) + ))))))) diff --git a/stdlib/source/library/lux/data/format/css.lux b/stdlib/source/library/lux/data/format/css.lux new file mode 100644 index 000000000..041feace9 --- /dev/null +++ b/stdlib/source/library/lux/data/format/css.lux @@ -0,0 +1,126 @@ +(.module: + [library + [lux (#- and) + [data + ["." maybe] + [number + ["." nat]] + ["." text + ["%" format (#+ format)] + ["." encoding (#+ Encoding)]] + [collection + ["." list ("#\." functor)]]] + [type + abstract] + [world + [net (#+ URL)]]]] + ["." / #_ + ["#." selector (#+ Selector Combinator)] + ["#." value (#+ Value Animation Percentage)] + ["#." font (#+ Font)] + ["#." style (#+ Style)] + ["#." query (#+ Query)]]) + +(abstract: #export Common Any) +(abstract: #export Special Any) + +(abstract: #export (CSS brand) + Text + + (def: #export css (-> (CSS Any) Text) (|>> :representation)) + + (def: #export empty (CSS Common) (:abstraction "")) + + (def: #export (rule selector style) + (-> (Selector Any) Style (CSS Common)) + (:abstraction (format (/selector.selector selector) "{" (/style.inline style) "}"))) + + (def: #export char-set + (-> Encoding (CSS Special)) + (|>> encoding.name + %.text + (text.enclose ["@charset " ";"]) + :abstraction)) + + (def: #export (font font) + (-> Font (CSS Special)) + (let [with-unicode (case (get@ #/font.unicode-range font) + (#.Some unicode-range) + (let [unicode-range' (format "U+" (\ nat.hex encode (get@ #/font.start unicode-range)) + "-" (\ nat.hex encode (get@ #/font.end unicode-range)))] + (list ["unicode-range" unicode-range'])) + + #.None + (list))] + (|> (list& ["font-family" (get@ #/font.family font)] + ["src" (format "url(" (get@ #/font.source font) ")")] + ["font-stretch" (|> font (get@ #/font.stretch) (maybe.default /value.normal-stretch) /value.value)] + ["font-style" (|> font (get@ #/font.style) (maybe.default /value.normal-style) /value.value)] + ["font-weight" (|> font (get@ #/font.weight) (maybe.default /value.normal-weight) /value.value)] + with-unicode) + (list\map (function (_ [property value]) + (format property ": " value ";"))) + (text.join-with /style.separator) + (text.enclose ["{" "}"]) + (format "@font-face") + :abstraction))) + + (def: #export (import url query) + (-> URL (Maybe Query) (CSS Special)) + (:abstraction (format (format "@import url(" (%.text url) ")") + (case query + (#.Some query) + (format " " (/query.query query)) + + #.None + "") + ";"))) + + (def: css-separator text.new-line) + + (type: #export Frame + {#when Percentage + #what Style}) + + (def: #export (key-frames animation frames) + (-> (Value Animation) (List Frame) (CSS Special)) + (:abstraction (format "@keyframes " (/value.value animation) " {" + (|> frames + (list\map (function (_ frame) + (format (/value.percentage (get@ #when frame)) " {" + (/style.inline (get@ #what frame)) + "}"))) + (text.join-with ..css-separator)) + "}"))) + + (template: (!compose <pre> <post>) + (:abstraction (format (:representation <pre>) ..css-separator + (:representation <post>)))) + + (def: #export (and pre post) + (-> (CSS Any) (CSS Any) (CSS Any)) + (!compose pre post)) + + (def: #export (alter combinator selector css) + (-> Combinator (Selector Any) (CSS Common) (CSS Common)) + (|> css + :representation + (text.split-all-with ..css-separator) + (list\map (|>> (format (/selector.selector (|> selector (combinator (/selector.tag ""))))))) + (text.join-with ..css-separator) + :abstraction)) + + (def: #export (dependent combinator selector style inner) + (-> Combinator (Selector Any) Style (CSS Common) (CSS Common)) + (!compose (..rule selector style) + (..alter combinator selector inner))) + + (template [<name> <combinator>] + [(def: #export <name> + (-> (Selector Any) Style (CSS Common) (CSS Common)) + (..dependent <combinator>))] + + [with-descendants /selector.in] + [with-children /selector.sub] + ) + ) diff --git a/stdlib/source/library/lux/data/format/css/font.lux b/stdlib/source/library/lux/data/format/css/font.lux new file mode 100644 index 000000000..c153ec0b8 --- /dev/null +++ b/stdlib/source/library/lux/data/format/css/font.lux @@ -0,0 +1,26 @@ +(.module: + [library + [lux #* + [type + abstract] + [control + [parser + ["s" code]]] + ["." macro + [syntax (#+ syntax:)]] + [world + [net (#+ URL)]]]] + ["." // #_ + ["#." value (#+ Value Font-Stretch Font-Style Font-Weight)]]) + +(type: #export Unicode-Range + {#start Nat + #end Nat}) + +(type: #export Font + {#family Text + #source URL + #stretch (Maybe (Value Font-Stretch)) + #style (Maybe (Value Font-Style)) + #weight (Maybe (Value Font-Weight)) + #unicode-range (Maybe Unicode-Range)}) diff --git a/stdlib/source/library/lux/data/format/css/property.lux b/stdlib/source/library/lux/data/format/css/property.lux new file mode 100644 index 000000000..273ab75b8 --- /dev/null +++ b/stdlib/source/library/lux/data/format/css/property.lux @@ -0,0 +1,503 @@ +(.module: + [library + [lux (#- All Cursor) + [control + [parser + ["s" code]]] + [type + abstract] + [macro + ["." template] + ["." code] + [syntax (#+ syntax:)]]]] + [// + [value (#+ All + Number + Length Thickness Time + Color + Location Fit + Slice + Alignment Animation-Direction + Animation Animation-Fill + Column-Fill Column-Span + Iteration Count + Play + Timing Visibility Attachment + Blend Span Image + Angle Repeat Border + Collapse Box-Decoration-Break Caption + Float Clear + Content + Cursor + Shadow Clip + Text-Direction + Display Empty + Filter + Flex-Direction Flex-Wrap + Font Font-Kerning Font-Size Font-Variant + Grid Grid-Content Grid-Flow Grid-Span Grid-Template + Hanging-Punctuation Hyphens Isolation + List-Style-Position List-Style-Type + Overflow Page-Break Pointer-Events + Position + Quotes + Resize Scroll-Behavior Table-Layout + Text-Align Text-Align-Last + Text-Decoration-Line Text-Decoration-Style + Text-Justification Text-Overflow Text-Transform + Transform Transform-Origin Transform-Style + Transition + Bidi User-Select + Vertical-Align + White-Space Word-Break Word-Wrap Writing-Mode + Z-Index)]]) + +(syntax: (text-identifier {identifier s.text}) + (wrap (list (code.local-identifier identifier)))) + +(abstract: #export (Property brand) + Text + + (def: #export name + (-> (Property Any) Text) + (|>> :representation)) + + (template [<brand> <alias>+ <property>+] + [(`` (template [<alias> <property>] + [(def: #export <alias> + (Property <brand>) + (:abstraction <property>))] + + (~~ (template.splice <alias>+)))) + + (with-expansions [<rows> (template.splice <property>+)] + (template [<property>] + [(`` (def: #export (~~ (text-identifier <property>)) + (Property <brand>) + (:abstraction <property>)))] + + <rows>))] + + [All + [] + [["all"]]] + + [Length + [] + [["border-image-outset"] + ["border-image-width"] + ["bottom"] + ["column-gap"] + ["column-width"] + ["flex-basis"] + ["grid-column-gap"] + ["grid-gap"] + ["grid-row-gap"] + ["height"] + ["left"] + ["letter-spacing"] + ["line-height"] + ["margin"] + ["margin-bottom"] + ["margin-left"] + ["margin-right"] + ["margin-top"] + ["max-height"] + ["max-width"] + ["min-height"] + ["min-width"] + ["outline-offset"] + ["padding"] + ["padding-bottom"] + ["padding-left"] + ["padding-right"] + ["padding-top"] + ["perspective"] + ["right"] + ["text-indent"] + ["top"] + ["width"] + ["word-spacing"]]] + + [Time + [] + [["animation-delay"] + ["animation-duration"] + ["transition-delay"] + ["transition-duration"]]] + + [Slice + [] + [["border-image-slice"]]] + + [Color + [[text-color "color"]] + [["background-color"] + ["border-color"] + ["border-bottom-color"] + ["border-left-color"] + ["border-right-color"] + ["border-top-color"] + ["caret-color"] + ["column-rule-color"] + ["outline-color"] + ["text-decoration-color"]]] + + [Alignment + [] + [["align-content"] + ["align-items"] + ["align-self"] + ["justify-content"]]] + + [Animation + [] + [["animation-name"]]] + + [Animation-Direction + [] + [["animation-direction"]]] + + [Animation-Fill + [] + [["animation-fill-mode"]]] + + [Column-Fill + [] + [["column-fill"]]] + + [Column-Span + [] + [["column-span"]]] + + [Iteration + [] + [["animation-iteration-count"]]] + + [Count + [] + [["column-count"] + ["flex-grow"] + ["flex-shrink"] + ["order"] + ["tab-size"]]] + + [Play + [] + [["animation-play-state"]]] + + [Timing + [] + [["animation-timing-function"] + ["transition-timing-function"]]] + + [Visibility + [] + [["backface-visibility"] + ["visibility"]]] + + [Attachment + [] + [["background-attachment"]]] + + [Blend + [] + [["background-blend-mode"] + ["mix-blend-mode"]]] + + [Image + [] + [["background-image"] + ["border-image-source"] + ["list-style-image"]]] + + [Span + [] + [["background-clip"] + ["background-origin"] + ["box-sizing"]]] + + [Location + [] + [["background-position"] + ["object-position"] + ["perspective-origin"]]] + + [Repeat + [] + [["background-repeat"] + ["border-image-repeat"]]] + + [Fit + [] + [["background-size"] + ["border-radius"] + ["border-bottom-left-radius"] + ["border-bottom-right-radius"] + ["border-top-left-radius"] + ["border-top-right-radius"] + ["border-spacing"] + ["object-fit"]]] + + [Border + [] + [["border-style"] + ["border-bottom-style"] + ["border-left-style"] + ["border-right-style"] + ["border-top-style"] + ["column-rule-style"] + ["outline-style"]]] + + [Thickness + [] + [["border-width"] + ["border-bottom-width"] + ["border-left-width"] + ["border-right-width"] + ["border-top-width"] + ["column-rule-width"] + ["outline-width"]]] + + [Collapse + [] + [["border-collapse"]]] + + [Box-Decoration-Break + [] + [["box-decoration-break"]]] + + [Caption + [] + [["caption-side"]]] + + [Clear + [] + [["clear"]]] + + [Shadow + [] + [["box-shadow"] + ["text-shadow"]]] + + [Clip + [] + [["clip"]]] + + [Content + [] + [["counter-reset"] + ["counter-increment"]]] + + [Cursor + [] + [["cursor"]]] + + [Text-Direction + [[text-direction "direction"]] + []] + + [Display + [] + [["display"]]] + + [Empty + [] + [["empty-cells"]]] + + [Filter + [] + [["filter"]]] + + [Flex-Direction + [] + [["flex-direction"]]] + + [Flex-Wrap + [] + [["flex-wrap"]]] + + [Float + [] + [["float"]]] + + [Font + [] + [["font-family"]]] + + [Font-Kerning + [] + [["font-kerning"]]] + + [Font-Size + [] + [["font-size"]]] + + [Number + [] + [["font-size-adjust"] + ["opacity"]]] + + [Font-Variant + [] + [["font-variant"]]] + + [Grid + [] + [["grid-area"]]] + + [Grid-Content + [] + [["grid-auto-columns"] + ["grid-auto-rows"] + ["grid-template-columns"] + ["grid-template-rows"]]] + + [Grid-Flow + [] + [["grid-auto-flow"]]] + + [Grid-Span + [] + [["grid-column-end"] + ["grid-column-start"] + ["grid-row-end"] + ["grid-row-start"]]] + + [Grid-Template + [] + [["grid-template-areas"]]] + + [Hanging-Punctuation + [] + [["hanging-punctuation"]]] + + [Hyphens + [] + [["hyphens"]]] + + [Isolation + [] + [["isolation"]]] + + [List-Style-Position + [] + [["list-style-position"]]] + + [List-Style-Type + [] + [["list-style-type"]]] + + [Overflow + [] + [["overflow"] + ["overflow-x"] + ["overflow-y"]]] + + [Page-Break + [] + [["page-break-after"] + ["page-break-before"] + ["page-break-inside"]]] + + [Pointer-Events + [] + [["pointer-events"]]] + + [Position + [] + [["position"]]] + + [Quotes + [] + [["quotes"]]] + + [Resize + [] + [["resize"]]] + + [Scroll-Behavior + [] + [["scroll-behavior"]]] + + [Table-Layout + [] + [["table-layout"]]] + + [Text-Align + [] + [["text-align"]]] + + [Text-Align-Last + [] + [["text-align-last"]]] + + [Text-Decoration-Line + [] + [["text-decoration-line"]]] + + [Text-Decoration-Style + [] + [["text-decoration-style"]]] + + [Text-Justification + [] + [["text-justify"]]] + + [Text-Overflow + [] + [["text-overflow"]]] + + [Text-Transform + [] + [["text-transform"]]] + + [Transform + [] + [["transform"]]] + + [Transform-Origin + [] + [["transform-origin"]]] + + [Transform-Style + [] + [["transform-style"]]] + + [Transition + [] + [["transition-property"]]] + + [Bidi + [] + [["unicode-bidi"]]] + + [User-Select + [] + [["user-select"]]] + + [Vertical-Align + [] + [["vertical-align"]]] + + [White-Space + [] + [["white-space"]]] + + [Word-Break + [] + [["word-break"]]] + + [Word-Wrap + [] + [["word-wrap"]]] + + [Writing-Mode + [] + [["writing-mode"]]] + + [Z-Index + [] + [["z-index"]]] + ) + ) diff --git a/stdlib/source/library/lux/data/format/css/query.lux b/stdlib/source/library/lux/data/format/css/query.lux new file mode 100644 index 000000000..3e40701eb --- /dev/null +++ b/stdlib/source/library/lux/data/format/css/query.lux @@ -0,0 +1,135 @@ +(.module: + [library + [lux (#- and or not) + [control + [parser + ["s" code]]] + [data + [text + ["%" format (#+ format)]]] + [macro + ["." template] + ["." code] + [syntax (#+ syntax:)]] + [type + abstract]]] + ["." // #_ + ["#." value (#+ Value Length Count Resolution Ratio + Orientation Scan Boolean Update + Block-Overflow Inline-Overflow + Display-Mode Color-Gamut Inverted-Colors + Pointer Hover + Light Scripting Motion Color-Scheme)]]) + +(syntax: (text-identifier {identifier s.text}) + (wrap (list (code.local-identifier identifier)))) + +(abstract: #export Media + Text + + (def: #export media + (-> Media Text) + (|>> :representation)) + + (template [<media>] + [(`` (def: #export (~~ (text-identifier <media>)) + Media + (:abstraction <media>)))] + + ["all"] + ["print"] + ["screen"] + ["speech"] + )) + +(abstract: #export Feature + Text + + (def: #export feature + (-> Feature Text) + (|>> :representation)) + + (template [<feature> <brand>] + [(`` (def: #export ((~~ (text-identifier <feature>)) input) + (-> (Value <brand>) Feature) + (:abstraction (format "(" <feature> ": " (//value.value input) ")"))))] + + ["min-color" Count] + ["color" Count] + ["max-color" Count] + + ["min-color-index" Count] + ["color-index" Count] + ["max-color-index" Count] + + ["min-monochrome" Count] + ["monochrome" Count] + ["max-monochrome" Count] + + ["min-height" Length] + ["height" Length] + ["max-height" Length] + + ["min-width" Length] + ["width" Length] + ["max-width" Length] + + ["min-resolution" Resolution] + ["resolution" Resolution] + ["max-resolution" Resolution] + + ["aspect-ratio" Ratio] + ["max-aspect-ratio" Ratio] + ["min-aspect-ratio" Ratio] + + ["display-mode" Display-Mode] + ["color-gamut" Color-Gamut] + ["grid" Boolean] + ["orientation" Orientation] + ["overflow-block" Block-Overflow] + ["overflow-inline" Inline-Overflow] + ["scan" Scan] + ["update" Update] + ["inverted-colors" Inverted-Colors] + ["pointer" Pointer] + ["any-pointer" Pointer] + ["hover" Hover] + ["any-hover" Hover] + ["light-level" Light] + ["scripting" Scripting] + ["prefers-reduced-motion" Motion] + ["prefers-color-scheme" Color-Scheme] + ) + ) + +(abstract: #export Query + Text + + (def: #export query + (-> Query Text) + (|>> :representation)) + + (template [<name> <operator>] + [(def: #export <name> + (-> Media Query) + (|>> ..media (format <operator>) :abstraction))] + + [except "not "] + [only "only "] + ) + + (def: #export not + (-> Feature Query) + (|>> ..feature (format "not ") :abstraction)) + + (template [<name> <operator>] + [(def: #export (<name> left right) + (-> Query Query Query) + (:abstraction (format (:representation left) + <operator> + (:representation right))))] + + [and " and "] + [or " or "] + ) + ) diff --git a/stdlib/source/library/lux/data/format/css/selector.lux b/stdlib/source/library/lux/data/format/css/selector.lux new file mode 100644 index 000000000..2a0210f7a --- /dev/null +++ b/stdlib/source/library/lux/data/format/css/selector.lux @@ -0,0 +1,205 @@ +(.module: + [library + [lux (#- or and for is? not) + [data + ["." text + ["%" format (#+ format)]] + [number + ["i" int]]] + [type + abstract] + [macro + ["." template]] + ["." locale (#+ Locale)]]]) + +(type: #export Label Text) + +(type: #export Tag Label) +(type: #export ID Label) +(type: #export Class Label) +(type: #export Attribute Label) + +(abstract: #export (Generic brand) Any) + +(template [<generic> <brand>] + [(abstract: <brand> Any) + (type: #export <generic> (Generic <brand>))] + + [Can-Chain Can-Chain'] + [Cannot-Chain Cannot-Chain'] + ) + +(abstract: #export Unique Any) +(abstract: #export Specific Any) +(abstract: #export Composite Any) + +(abstract: #export (Selector kind) + Text + + (def: #export selector + (-> (Selector Any) Text) + (|>> :representation)) + + (def: #export any + (Selector Cannot-Chain) + (:abstraction "*")) + + (def: #export tag + (-> Tag (Selector Cannot-Chain)) + (|>> :abstraction)) + + (template [<name> <type> <prefix> <kind>] + [(def: #export <name> + (-> <type> (Selector <kind>)) + (|>> (format <prefix>) :abstraction))] + + [id ID "#" Unique] + [class Class "." Can-Chain] + ) + + (template [<right> <left> <combo> <combinator>+] + [(`` (template [<combinator> <name>] + [(def: #export (<name> right left) + (-> (Selector <right>) (Selector <left>) (Selector <combo>)) + (:abstraction (format (:representation left) + <combinator> + (:representation right))))] + + (~~ (template.splice <combinator>+))))] + + [Can-Chain (Generic Any) Can-Chain + [["" and]]] + [Unique (Generic Any) Composite + [["" for]]] + [Specific (Generic Any) Composite + [["" at]]] + [Any Any Composite + [["," or] + [" " in] + [">" sub] + ["+" next] + ["~" later]]] + ) + + (type: #export Combinator + (-> (Selector Any) (Selector Any) (Selector Composite))) + + (def: #export (with? attribute) + (-> Attribute (Selector Can-Chain)) + (:abstraction (format "[" attribute "]"))) + + (template [<check> <name>] + [(def: #export (<name> attribute value) + (-> Attribute Text (Selector Can-Chain)) + (:abstraction (format "[" attribute <check> value "]")))] + + ["=" is?] + ["~=" has?] + ["|=" has-start?] + ["^=" starts?] + ["$=" ends?] + ["*=" contains?] + ) + + (template [<kind> <pseudo>+] + [(`` (template [<name> <pseudo>] + [(def: #export <name> + (Selector Can-Chain) + (:abstraction <pseudo>))] + + (~~ (template.splice <pseudo>+))))] + + [Can-Chain + [[active ":active"] + [checked ":checked"] + [default ":default"] + [disabled ":disabled"] + [empty ":empty"] + [enabled ":enabled"] + [first-child ":first-child"] + [first-of-type ":first-of-type"] + [focused ":focus"] + [hovered ":hover"] + [in-range ":in-range"] + [indeterminate ":indeterminate"] + [invalid ":invalid"] + [last-child ":last-child"] + [last-of-type ":last-of-type"] + [link ":link"] + [only-of-type ":only-of-type"] + [only-child ":only-child"] + [optional ":optional"] + [out-of-range ":out-of-range"] + [read-only ":read-only"] + [read-write ":read-write"] + [required ":required"] + [root ":root"] + [target ":target"] + [valid ":valid"] + [visited ":visited"]]] + + [Specific + [[after "::after"] + [before "::before"] + [first-letter "::first-letter"] + [first-line "::first-line"] + [placeholder "::placeholder"] + [selection "::selection"]]] + ) + + (def: #export (language locale) + (-> Locale (Selector Can-Chain)) + (|> locale + locale.code + (text.enclose ["(" ")"]) + (format ":lang") + :abstraction)) + + (def: #export not + (-> (Selector Any) (Selector Can-Chain)) + (|>> :representation + (text.enclose ["(" ")"]) + (format ":not") + :abstraction)) + + (abstract: #export Index + Text + + (def: #export index + (-> Nat Index) + (|>> %.nat :abstraction)) + + (template [<name> <index>] + [(def: #export <name> Index (:abstraction <index>))] + + [odd "odd"] + [even "even"] + ) + + (type: #export Formula + {#constant Int + #variable Int}) + + (def: #export (formula input) + (-> Formula Index) + (let [(^slots [#constant #variable]) input] + (:abstraction (format (if (i.< +0 variable) + (%.int variable) + (%.nat (.nat variable))) + (%.int constant))))) + + (template [<name> <pseudo>] + [(def: #export (<name> index) + (-> Index (Selector Can-Chain)) + (|> (:representation index) + (text.enclose ["(" ")"]) + (format <pseudo>) + (:abstraction Selector)))] + + [nth-child ":nth-child"] + [nth-last-child ":nth-last-child"] + [nth-last-of-type ":nth-last-of-type"] + [nth-of-type ":nth-of-type"] + ) + ) + ) diff --git a/stdlib/source/library/lux/data/format/css/style.lux b/stdlib/source/library/lux/data/format/css/style.lux new file mode 100644 index 000000000..5f2c68888 --- /dev/null +++ b/stdlib/source/library/lux/data/format/css/style.lux @@ -0,0 +1,36 @@ +(.module: + [library + [lux #* + [data + [text + ["%" format (#+ format)]]] + [type + abstract]]] + ["." // #_ + ["#." value (#+ Value)] + ["#." property (#+ Property)]]) + +(abstract: #export Style + Text + + {#.doc "The style associated with a CSS selector."} + + (def: #export empty + Style + (:abstraction "")) + + (def: #export separator + " ") + + (def: #export (with [property value]) + (All [brand] + (-> [(Property brand) (Value brand)] + (-> Style Style))) + (|>> :representation + (format (//property.name property) ": " (//value.value value) ";" ..separator) + :abstraction)) + + (def: #export inline + (-> Style Text) + (|>> :representation)) + ) diff --git a/stdlib/source/library/lux/data/format/css/value.lux b/stdlib/source/library/lux/data/format/css/value.lux new file mode 100644 index 000000000..f85272a04 --- /dev/null +++ b/stdlib/source/library/lux/data/format/css/value.lux @@ -0,0 +1,1329 @@ +(.module: + [library + [lux (#- All Cursor and static false true) + [control + [parser + ["s" code]]] + [data + ["." color] + ["." product] + ["." maybe] + [number + ["n" nat] + ["i" int] + ["r" rev] + ["f" frac]] + ["." text + ["%" format (#+ Format format)]] + [collection + ["." list ("#\." functor)]]] + [type + abstract] + [macro + ["." template] + ["." code] + [syntax (#+ syntax:)]] + [world + [net (#+ URL)]]]] + [// + [selector (#+ Label)]]) + +(syntax: (text-identifier {identifier s.text}) + (wrap (list (code.local-identifier identifier)))) + +(template: (enumeration: <abstraction> <representation> <out> <sample>+ <definition>+) + (abstract: #export <abstraction> + <representation> + + (def: #export <out> + (-> <abstraction> <representation>) + (|>> :representation)) + + (`` (template [<name> <value>] + [(def: #export <name> <abstraction> (:abstraction <value>))] + + (~~ (template.splice <sample>+)) + )) + + (template.splice <definition>+))) + +(template: (multi: <multi> <type> <separator>) + (def: #export (<multi> pre post) + (-> (Value <type>) (Value <type>) (Value <type>)) + (:abstraction (format (:representation pre) + <separator> + (:representation post))))) + +(def: (%number value) + (Format Frac) + (let [raw (%.frac value)] + (if (f.< +0.0 value) + raw + (|> raw (text.split 1) maybe.assume product.right)))) + +(abstract: #export (Value brand) + Text + + (def: #export value + (-> (Value Any) Text) + (|>> :representation)) + + (template [<name> <value>] + [(def: #export <name> Value (:abstraction <value>))] + + [initial "initial"] + [inherit "inherit"] + [unset "unset"] + ) + + (template [<brand> <alias>+ <value>+] + [(abstract: #export <brand> Any) + + (`` (template [<name> <value>] + [(def: #export <name> + (Value <brand>) + (:abstraction <value>))] + + (~~ (template.splice <alias>+)))) + + (with-expansions [<rows> (template.splice <value>+)] + (template [<value>] + [(`` (def: #export (~~ (text-identifier <value>)) + (Value <brand>) + (:abstraction <value>)))] + + <rows>))] + + [All + [] + []] + + [Number + [] + []] + + [Length + [] + []] + + [Time + [] + []] + + [Thickness + [] + [["medium"] + ["thin"] + ["thick"]]] + + [Slice + [[full-slice "fill"]] + []] + + [Alignment + [[auto-alignment "auto"]] + [["stretch"] + ["center"] + ["flex-start"] + ["flex-end"] + ["baseline"] + ["space-between"] + ["space-around"]]] + + [Animation + [] + []] + + [Animation-Direction + [[normal-direction "normal"]] + [["reverse"] + ["alternate"] + ["alternate-reverse"]]] + + [Animation-Fill + [[fill-forwards "forwards"] + [fill-backwards "backwards"] + [fill-both "both"]] + []] + + [Column-Fill + [] + [["balance"] + ["auto"]]] + + [Column-Span + [] + [["all"]]] + + [Iteration + [] + [["infinite"]]] + + [Count + [] + []] + + [Play + [] + [["paused"] + ["running"]]] + + [Timing + [] + [["linear"] + ["ease"] + ["ease-in"] + ["ease-out"] + ["ease-in-out"] + ["step-start"] + ["step-end"]]] + + [Visibility + [[invisible "hidden"] + [collapse-visibility "collapse"]] + [["visible"]]] + + [Attachment + [[scroll-attachment "scroll"] + [fixed-attachment "fixed"] + [local-attachment "local"]] + []] + + [Blend + [[normal-blend "normal"]] + [["multiply"] + ["screen"] + ["overlay"] + ["darken"] + ["lighten"] + ["color-dodge"] + ["color-burn"] + ["difference"] + ["exclusion"] + ["hue"] + ["saturation"] + ["color"] + ["luminosity"]]] + + [Span + [] + [["border-box"] + ["padding-box"] + ["content-box"]]] + + [Image + [[no-image "none"]] + []] + + [Repeat + [[stretch-repeat "stretch"]] + [["repeat"] + ["repeat-x"] + ["repeat-y"] + ["no-repeat"] + ["space"] + ["round"]]] + + [Location + [[left-top "left top"] + [left-center "left center"] + [left-bottom "left bottom"] + [right-top "right top"] + [right-center "right center"] + [right-bottom "right bottom"] + [center-top "center top"] + [center-center "center center"] + [center-bottom "center bottom"]] + []] + + [Fit + [[no-fit "none"]] + [["fill"] + ["cover"] + ["contain"] + ["scale-down"]]] + + [Border + [] + [["hidden"] + ["dotted"] + ["dashed"] + ["solid"] + ["double"] + ["groove"] + ["ridge"] + ["inset"] + ["outset"]]] + + [Collapse + [] + [["separate"] + ["collapse"]]] + + [Box-Decoration-Break + [] + [["slice"] + ["clone"]]] + + [Caption + [] + [["top"] + ["bottom"]]] + + [Float + [[float-left "left"] + [float-right "right"]] + []] + + [Clear + [[clear-left "left"] + [clear-right "right"] + [clear-both "both"]] + []] + + [Counter + [] + []] + + [Content + [] + [["open-quote"] + ["close-quote"] + ["no-open-quote"] + ["no-close-quote"]]] + + [Cursor + [[horizontal-text "text"] + [no-cursor "none"]] + [["alias"] + ["all-scroll"] + ["cell"] + ["context-menu"] + ["col-resize"] + ["copy"] + ["crosshair"] + ["default"] + ["e-resize"] + ["ew-resize"] + ["grab"] + ["grabbing"] + ["help"] + ["move"] + ["n-resize"] + ["ne-resize"] + ["nesw-resize"] + ["ns-resize"] + ["nw-resize"] + ["nwse-resize"] + ["no-drop"] + ["not-allowed"] + ["pointer"] + ["progress"] + ["row-resize"] + ["s-resize"] + ["se-resize"] + ["sw-resize"] + ["vertical-text"] + ["w-resize"] + ["wait"] + ["zoom-in"] + ["zoom-out"]]] + + [Shadow + [] + []] + + [Clip + [] + []] + + [Text-Direction + [[left-to-right "ltr"] + [right-to-left "rtl"]] + []] + + [Display + [[grid-display "grid"] + [no-display "none"]] + [["inline"] + ["block"] + ["contents"] + ["flex"] + ["inline-block"] + ["inline-flex"] + ["inline-grid"] + ["inline-table"] + ["list-item"] + ["run-in"] + ["table"] + ["table-caption"] + ["table-column-group"] + ["table-header-group"] + ["table-footer-group"] + ["table-row-group"] + ["table-cell"] + ["table-column"] + ["table-row"]]] + + [Empty + [] + [["show"] + ["hide"]]] + + [Filter + [] + []] + + [Flex-Direction + [] + [["row"] + ["row-reverse"] + ["column"] + ["column-reverse"]]] + + [Flex-Wrap + [[no-wrap "nowrap"]] + [["wrap"] + ["wrap-reverse"]]] + + [Font-Kerning + [[auto-kerning "auto"] + [normal-kerning "normal"] + [no-kerning "none"]] + []] + + [Font-Size + [[medium-size "medium"] + [xx-small-size "xx-small"] + [x-small-size "x-small"] + [small-size "small"] + [large-size "large"] + [x-large-size "x-large"] + [xx-large-size "xx-large"] + [smaller-size "smaller"] + [larger-size "larger"]] + []] + + [Font-Stretch + [[normal-stretch "normal"]] + [["condensed"] + ["ultra-condensed"] + ["extra-condensed"] + ["semi-condensed"] + ["expanded"] + ["semi-expanded"] + ["extra-expanded"] + ["ultra-expanded"]]] + + [Font-Style + [[normal-style "normal"]] + [["italic"] + ["oblique"]]] + + [Font-Weight + [[normal-weight "normal"] + [weight-100 "100"] + [weight-200 "200"] + [weight-300 "300"] + [weight-400 "400"] + [weight-500 "500"] + [weight-600 "600"] + [weight-700 "700"] + [weight-800 "800"] + [weight-900 "900"]] + [["bold"]]] + + [Font-Variant + [[normal-font "normal"]] + [["small-caps"]]] + + [Grid + [] + []] + + [Grid-Content + [[auto-content "auto"]] + [["max-content"] + ["min-content"]]] + + [Grid-Flow + [[row-flow "row"] + [column-flow "column"] + [dense-flow "dense"] + [row-dense-flow "row dense"] + [column-dense-flow "column dense"]] + []] + + [Grid-Span + [[auto-span "auto"]] + []] + + [Grid-Template + [] + []] + + [Hanging-Punctuation + [[no-hanging-punctuation "none"]] + [["first"] + ["last"] + ["allow-end"] + ["force-end"]]] + + [Hyphens + [[no-hyphens "none"] + [manual-hyphens "manual"] + [auto-hyphens "auto"]] + []] + + [Orientation + [] + [["portrait"] + ["landscape"]]] + + [Resolution + [] + []] + + [Scan + [] + [["interlace"] + ["progressive"]]] + + [Boolean + [[false "0"] + [true "1"]] + []] + + [Update + [[no-update "none"] + [slow-update "slow"] + [fast-update "fast"]] + []] + + [Block-Overflow + [[no-block-overflow "none"] + [scroll-block-overflow "scroll"] + [optional-paged-block-overflow "optional-paged"] + [paged-block-overflow "paged"]] + []] + + [Inline-Overflow + [[no-inline-overflow "none"] + [scroll-inline-overflow "scroll"]] + []] + + [Display-Mode + [] + [["fullscreen"] + ["standalone"] + ["minimal-ui"] + ["browser"]]] + + [Color-Gamut + [] + [["srgb"] + ["p3"] + ["rec2020"]]] + + [Inverted-Colors + [[no-inverted-colors "none"] + [inverted-colors "inverted"]] + []] + + [Pointer + [[no-pointer "none"] + [coarse-pointer "coarse"] + [fine-pointer "fine"]] + []] + + [Hover + [[no-hover "none"]] + [["hover"]]] + + [Light + [[dim-light "dim"] + [normal-light "normal"] + [washed-light "washed"]] + []] + + [Ratio + [] + []] + + [Scripting + [[no-scripting "none"] + [initial-scripting-only "initial-only"] + [scripting-enabled "enabled"]] + []] + + [Motion + [[no-motion-preference "no-preference"] + [reduced-motion "reduce"]] + []] + + [Color-Scheme + [[no-color-scheme-preference "no-preference"] + [light-color-scheme "light"] + [dark-color-scheme "dark"]] + []] + + [Isolation + [[auto-isolation "auto"]] + [["isolate"]]] + + [List-Style-Position + [] + [["inside"] + ["outside"]]] + + [List-Style-Type + [[no-list-style "none"]] + [["disc"] + ["armenian"] + ["circle"] + ["cjk-ideographic"] + ["decimal"] + ["decimal-leading-zero"] + ["georgian"] + ["hebrew"] + ["hiragana"] + ["hiragana-iroha"] + ["katakana"] + ["katakana-iroha"] + ["lower-alpha"] + ["lower-greek"] + ["lower-latin"] + ["lower-roman"] + ["square"] + ["upper-alpha"] + ["upper-greek"] + ["upper-latin"] + ["upper-roman"]]] + + [Color + [] + []] + + [Overflow + [[visible-overflow "visible"] + [hidden-overflow "hidden"] + [scroll-overflow "scroll"] + [auto-overflow "auto"]] + []] + + [Page-Break + [[auto-page-break "auto"] + [always-page-break "always"] + [avoid-page-break "avoid"] + [left-page-break "left"] + [right-page-break "right"]] + []] + + [Pointer-Events + [[auto-pointer-events "auto"] + [no-pointer-events "none"]] + []] + + [Position + [] + [["static"] + ["absolute"] + ["fixed"] + ["relative"] + ["sticky"]]] + + [Quotes + [[no-quotes "none"]] + []] + + [Resize + [[resize-none "none"] + [resize-both "both"] + [resize-horizontal "horizontal"] + [resize-vertical "vertical"]] + []] + + [Scroll-Behavior + [[auto-scroll-behavior "auto"] + [smooth-scroll-behavior "smooth"]] + []] + + [Table-Layout + [[auto-table-layout "auto"] + [fixed-table-layout "fixed"]] + []] + + [Text-Align + [[left-text-align "left"] + [right-text-align "right"] + [center-text-align "center"] + [justify-text-align "justify"]] + []] + + [Text-Align-Last + [[auto-text-align-last "auto"] + [left-text-align-last "left"] + [right-text-align-last "right"] + [center-text-align-last "center"] + [justify-text-align-last "justify"] + [start-text-align-last "start"] + [end-text-align-last "end"]] + []] + + [Text-Decoration-Line + [[no-text-decoration-line "none"] + [underline-text-decoration-line "underline"] + [overline-text-decoration-line "overline"] + [line-through-text-decoration-line "line-through"]] + []] + + [Text-Decoration-Style + [[solid-text-decoration-style "solid"] + [double-text-decoration-style "double"] + [dotted-text-decoration-style "dotted"] + [dashed-text-decoration-style "dashed"] + [wavy-text-decoration-style "wavy"]] + []] + + [Text-Justification + [[auto-text-justification "auto"] + [inter-word-text-justification "inter-word"] + [inter-character-text-justification "inter-character"] + [no-text-justification "none"]] + []] + + [Text-Overflow + [[clip-text-overflow "clip"] + [ellipsis-text-overflow "ellipsis"]] + []] + + [Text-Transform + [[no-text-transform "none"]] + [["capitalize"] + ["uppercase"] + ["lowercase"]]] + + [Transform + [[no-transform "none"]] + []] + + [Transform-Origin + [] + []] + + [Transform-Style + [] + [["flat"] + ["preserve-3d"]]] + + [Transition + [[transition-none "none"] + [transition-all "all"]] + []] + + [Bidi + [[bidi-normal "normal"] + [bidi-embed "embed"] + [bidi-isolate "isolate"] + [bidi-isolate-override "isolate-override"] + [bidi-plaintext "plaintext"]] + [["bidi-override"]]] + + [User-Select + [[user-select-auto "auto"] + [user-select-none "none"] + [user-select-text "text"] + [user-select-all "all"]] + []] + + [Vertical-Align + [[vertical-align-baseline "baseline"] + [vertical-align-sub "sub"] + [vertical-align-super "super"] + [vertical-align-top "top"] + [vertical-align-text-top "text-top"] + [vertical-align-middle "middle"] + [vertical-align-bottom "bottom"] + [vertical-align-text-bottom "text-bottom"]] + []] + + [White-Space + [[normal-white-space "normal"] + [no-wrap-white-space "nowrap"] + [pre-white-space "pre"] + [pre-line-white-space "pre-line"] + [pre-wrap-white-space "pre-wrap"]] + []] + + [Word-Break + [[normal-word-break "normal"]] + [["break-all"] + ["keep-all"] + ["break-word"]]] + + [Word-Wrap + [[normal-word-wrap "normal"] + [break-word-word-wrap "break-word"]] + []] + + [Writing-Mode + [[top-to-bottom-writing-mode "horizontal-tb"] + [left-to-right-writing-mode "vertical-rl"] + [right-to-left-writing-mode "vertical-lr"]] + []] + + [Z-Index + [] + []] + ) + + (def: value-separator ",") + + (def: (apply name inputs) + (-> Text (List Text) Value) + (|> inputs + (text.join-with ..value-separator) + (text.enclose ["(" ")"]) + (format name) + :abstraction)) + + (enumeration: Step Text + step + [[start "start"] + [end "end"]] + []) + + (def: #export (steps intervals step) + (-> Nat Step (Value Timing)) + (..apply "steps" (list (%.nat intervals) (..step step)))) + + (def: #export (cubic-bezier p0 p1 p2 p3) + (-> Frac Frac Frac Frac (Value Timing)) + (|> (list p0 p1 p2 p3) + (list\map %number) + (..apply "cubic-bezier"))) + + (template [<name> <brand>] + [(def: #export <name> + (-> Nat (Value <brand>)) + (|>> %.nat :abstraction))] + + [iteration Iteration] + [count Count] + [slice-number/1 Slice] + [span-line Grid-Span] + ) + + (def: #export animation + (-> Label (Value Animation)) + (|>> :abstraction)) + + (def: #export (rgb color) + (-> color.Color (Value Color)) + (let [[red green blue] (color.to-rgb color)] + (..apply "rgb" (list (%.nat red) + (%.nat green) + (%.nat blue))))) + + (def: #export (rgba pigment) + (-> color.Pigment (Value Color)) + (let [(^slots [#color.color #color.alpha]) pigment + [red green blue] (color.to-rgb color)] + (..apply "rgba" (list (%.nat red) + (%.nat green) + (%.nat blue) + (if (r.= (\ r.interval top) alpha) + "1.0" + (format "0" (%.rev alpha))))))) + + (template [<name> <suffix>] + [(def: #export (<name> value) + (-> Frac (Value Length)) + (:abstraction (format (%number value) <suffix>)))] + + [em "em"] + [ex "ex"] + [rem "rem"] + [ch "ch"] + [vw "vw"] + [vh "vh"] + [vmin "vmin"] + [vmax "vmax"] + [% "%"] + [cm "cm"] + [mm "mm"] + [in "in"] + [px "px"] + [pt "pt"] + [pc "pc"] + [fr "fr"] + ) + + (def: (%int value) + (Format Int) + (if (i.< +0 value) + (%.int value) + (%.nat (.nat value)))) + + (template [<name> <suffix>] + [(def: #export (<name> value) + (-> Int (Value Time)) + (:abstraction (format (if (i.< +0 value) + (%.int value) + (%.nat (.nat value))) + <suffix>)))] + + + [seconds "s"] + [milli-seconds "ms"] + ) + + (def: #export thickness + (-> (Value Length) (Value Thickness)) + (|>> :transmutation)) + + (def: slice-separator " ") + + (def: #export (slice-number/2 horizontal vertical) + (-> Nat Nat (Value Slice)) + (:abstraction (format (%.nat horizontal) ..slice-separator + (%.nat vertical)))) + + (abstract: #export Stop + Text + + (def: #export stop + (-> (Value Color) Stop) + (|>> (:representation Value) (:abstraction Stop))) + + (def: stop-separator " ") + + (def: #export (single-stop length color) + (-> (Value Length) (Value Color) Stop) + (:abstraction (format (:representation Value color) ..stop-separator + (:representation Value length)))) + + (def: #export (double-stop start end color) + (-> (Value Length) (Value Length) (Value Color) Stop) + (:abstraction (format (:representation Value color) ..stop-separator + (:representation Value start) ..stop-separator + (:representation Value end)))) + + (abstract: #export Hint + Text + + (def: #export hint + (-> (Value Length) Hint) + (|>> (:representation Value) (:abstraction Hint))) + + (def: (with-hint [hint stop]) + (-> [(Maybe Hint) Stop] Text) + (case hint + #.None + (:representation Stop stop) + + (#.Some hint) + (format (:representation Hint hint) ..value-separator (:representation Stop stop)))))) + + (type: #export (List/1 a) + [a (List a)]) + + (abstract: #export Angle + Text + + (def: #export angle + (-> Angle Text) + (|>> :representation)) + + (def: #export (turn value) + (-> Rev Angle) + (:abstraction (format (%.rev value) "turn"))) + + (def: degree-limit Nat 360) + + (def: #export (degree value) + (-> Nat Angle) + (:abstraction (format (%.nat (n.% ..degree-limit value)) "deg"))) + + (template [<degree> <name>] + [(def: #export <name> Angle (..degree <degree>))] + + [000 to-top] + [090 to-right] + [180 to-bottom] + [270 to-left] + ) + + (template [<name> <function>] + [(def: #export (<name> angle start next) + (-> Angle Stop (List/1 [(Maybe Hint) Stop]) (Value Image)) + (let [[now after] next] + (..apply <function> (list& (:representation Angle angle) + (with-hint now) + (list\map with-hint after)))))] + + [linear-gradient "linear-gradient"] + [repeating-linear-gradient "repeating-linear-gradient"] + ) + ) + + (abstract: #export Percentage + Text + + (def: #export percentage + (-> Percentage Text) + (|>> :representation)) + + (def: percentage-limit Nat (.inc 100)) + + (def: #export (%% value) + (-> Nat Percentage) + (:abstraction (format (%.nat (n.% percentage-limit value)) "%"))) + + (def: #export slice-percent/1 + (-> Percentage (Value Slice)) + (|>> :representation (:abstraction Value))) + + (def: #export (slice-percent/2 horizontal vertical) + (-> Percentage Percentage (Value Slice)) + (:abstraction Value (format (:representation horizontal) ..slice-separator + (:representation vertical)))) + + (template [<input> <pre> <function>+] + [(`` (template [<name> <function>] + [(def: #export <name> + (-> <input> (Value Filter)) + (|>> <pre> (list) (..apply <function>)))] + + (~~ (template.splice <function>+))))] + + [Nat (<| (:representation Value) ..px n.frac) + [[blur "blur"]]] + [Nat (<| ..angle ..degree) + [[hue-rotate "hue-rotate"]]] + [Percentage (:representation Percentage) + [[brightness "brightness"] + [contrast "contrast"] + [grayscale "grayscale"] + [invert "invert"] + [opacity "opacity"] + [saturate "saturate"] + [sepia "sepia"]]] + ) + ) + + (def: #export svg-filter + (-> URL (Value Filter)) + (|>> (list) (..apply "url"))) + + (def: default-shadow-length (px +0.0)) + + (def: #export (drop-shadow horizontal vertical blur spread color) + (-> (Value Length) (Value Length) + (Maybe (Value Length)) (Maybe (Value Length)) + (Value Color) + (Value Filter)) + (|> (list (:representation horizontal) + (:representation vertical) + (|> blur (maybe.default ..default-shadow-length) :representation) + (|> spread (maybe.default ..default-shadow-length) :representation) + (:representation color)) + (text.join-with " ") + (list) + (..apply "drop-shadow"))) + + (def: length-separator " ") + + (template [<name> <type>] + [(def: #export (<name> horizontal vertical) + (-> (Value Length) (Value Length) (Value <type>)) + (:abstraction (format (:representation horizontal) + ..length-separator + (:representation vertical))))] + + [location Location] + [fit Fit] + ) + + (def: #export (fit/1 length) + (-> (Value Length) (Value Fit)) + (..fit length length)) + + (def: #export image + (-> URL (Value Image)) + (|>> %.text + (list) + (..apply "url"))) + + (enumeration: Shape Text + shape + [[ellipse-shape "ellipse"] + [circle-shape "circle"]] + []) + + (enumeration: Extent Text + extent + [[closest-side "closest-side"] + [closest-corner "closest-corner"] + [farthest-side "farthest-side"] + [farthest-corner "farthest-corner"]] + []) + + (template [<name> <function>] + [(def: #export (<name> shape extent location start next) + (-> Shape (Maybe Extent) (Value Location) + Stop (List/1 [(Maybe Hint) Stop]) + (Value Image)) + (let [after-extent (format "at " (:representation location)) + with-extent (case extent + (#.Some extent) + (format (..extent extent) " " after-extent) + + #.None + after-extent) + where (format (..shape shape) " " with-extent) + [now after] next] + (..apply <function> (list& (..shape shape) + (with-hint now) + (list\map with-hint after)))))] + + [radial-gradient "radial-gradient"] + [repeating-radial-gradient "repeating-radial-gradient"] + ) + + (def: #export (shadow horizontal vertical blur spread color inset?) + (-> (Value Length) (Value Length) + (Maybe (Value Length)) (Maybe (Value Length)) + (Value Color) Bit + (Value Shadow)) + (let [with-inset (if inset? + (list "inset") + (list))] + (|> (list& (:representation horizontal) + (:representation vertical) + (|> blur (maybe.default ..default-shadow-length) :representation) + (|> spread (maybe.default ..default-shadow-length) :representation) + (:representation color) + with-inset) + (text.join-with " ") + :abstraction))) + + (type: #export Rectangle + {#top (Value Length) + #right (Value Length) + #bottom (Value Length) + #left (Value Length)}) + + (def: #export (clip rectangle) + (-> Rectangle (Value Clip)) + (`` (..apply "rect" (list (~~ (template [<side>] + [(:representation (get@ <side> rectangle))] + + [#top] [#right] [#bottom] [#left])))))) + + (def: #export counter + (-> Label (Value Counter)) + (|>> :abstraction)) + + (def: #export current-count + (-> (Value Counter) (Value Content)) + (|>> :representation (list) (..apply "counter"))) + + (def: #export text + (-> Text (Value Content)) + (|>> %.text :abstraction)) + + (def: #export attribute + (-> Label (Value Content)) + (|>> (list) (..apply "attr"))) + + (def: #export media + (-> URL (Value Content)) + (|>> (list) (..apply "url"))) + + (enumeration: Font Text + font-name + [[serif "serif"] + [sans-serif "sans-serif"] + [cursive "cursive"] + [fantasy "fantasy"] + [monospace "monospace"]] + [(def: #export font + (-> Text Font) + (|>> %.text :abstraction)) + + (def: #export (font-family options) + (-> (List Font) (Value Font)) + (case options + (#.Cons _) + (|> options + (list\map ..font-name) + (text.join-with ",") + (:abstraction Value)) + + #.Nil + ..initial))]) + + (def: #export font-size + (-> (Value Length) (Value Font-Size)) + (|>> :transmutation)) + + (def: #export number + (-> Frac (Value Number)) + (|>> %number :abstraction)) + + (def: #export grid + (-> Label (Value Grid)) + (|>> :abstraction)) + + (def: #export fit-content + (-> (Value Length) (Value Grid-Content)) + (|>> :representation (list) (..apply "fit-content"))) + + (def: #export (min-max min max) + (-> (Value Grid-Content) (Value Grid-Content) (Value Grid-Content)) + (..apply "minmax" (list (:representation min) + (:representation max)))) + + (def: #export grid-span + (-> Nat (Value Grid-Span)) + (|>> %.nat (format "span ") :abstraction)) + + (def: grid-column-separator " ") + (def: grid-row-separator " ") + + (def: #export grid-template + (-> (List (List (Maybe (Value Grid)))) (Value Grid-Template)) + (let [empty (: (Value Grid) + (:abstraction "."))] + (|>> (list\map (|>> (list\map (|>> (maybe.default empty) + :representation)) + (text.join-with ..grid-column-separator) + (text.enclose ["'" "'"]))) + (text.join-with ..grid-row-separator) + :abstraction))) + + (def: #export (resolution dpi) + (-> Nat (Value Resolution)) + (:abstraction (format (%.nat dpi) "dpi"))) + + (def: #export (ratio numerator denominator) + (-> Nat Nat (Value Ratio)) + (:abstraction (format (%.nat numerator) "/" (%.nat denominator)))) + + (enumeration: Quote Text + quote-text + [[double-quote "\0022"] + [single-quote "\0027"] + [single-left-angle-quote "\2039"] + [single-right-angle-quote "\203A"] + [double-left-angle-quote "\00AB"] + [double-right-angle-quote "\00BB"] + [single-left-quote "\2018"] + [single-right-quote "\2019"] + [double-left-quote "\201C"] + [double-right-quote "\201D"] + [low-double-quote "\201E"]] + [(def: #export quote + (-> Text Quote) + (|>> :abstraction))]) + + (def: quote-separator " ") + + (def: #export (quotes [left0 right0] [left1 right1]) + (-> [Quote Quote] [Quote Quote] (Value Quotes)) + (|> (list left0 right0 left1 right1) + (list\map (|>> ..quote-text %.text)) + (text.join-with ..quote-separator) + :abstraction)) + + (def: #export (matrix-2d [a b] [c d] [tx ty]) + (-> [Frac Frac] + [Frac Frac] + [Frac Frac] + (Value Transform)) + (|> (list a b c d tx ty) + (list\map %number) + (..apply "matrix"))) + + (def: #export (matrix-3d [a0 b0 c0 d0] [a1 b1 c1 d1] [a2 b2 c2 d2] [a3 b3 c3 d3]) + (-> [Frac Frac Frac Frac] + [Frac Frac Frac Frac] + [Frac Frac Frac Frac] + [Frac Frac Frac Frac] + (Value Transform)) + (|> (list a0 b0 c0 d0 a1 b1 c1 d1 a2 b2 c2 d2 a3 b3 c3 d3) + (list\map %number) + (..apply "matrix3d"))) + + (template [<name> <function> <input-types> <input-values>] + [(`` (def: #export (<name> [(~~ (template.splice <input-values>))]) + (-> [(~~ (template.splice <input-types>))] (Value Transform)) + (|> (list (~~ (template.splice <input-values>))) + (list\map %number) + (..apply <function>))))] + + [translate-2d "translate" [Frac Frac] [x y]] + [translate-3d "translate3d" [Frac Frac Frac] [x y z]] + [translate-x "translateX" [Frac] [value]] + [translate-y "translateY" [Frac] [value]] + [translate-z "translateZ" [Frac] [value]] + + [scale-2d "scale" [Frac Frac] [x y]] + [scale-3d "scale3d" [Frac Frac Frac] [x y z]] + [scale-x "scaleX" [Frac] [value]] + [scale-y "scaleY" [Frac] [value]] + [scale-z "scaleZ" [Frac] [value]] + + [perspective "perspective" [Frac] [value]] + ) + + (template [<name> <function> <input-types> <input-values>] + [(`` (def: #export (<name> [(~~ (template.splice <input-values>))]) + (-> [(~~ (template.splice <input-types>))] (Value Transform)) + (|> (list (~~ (template.splice <input-values>))) + (list\map ..angle) + (..apply <function>))))] + + [rotate-2d "rotate" [Angle] [angle]] + [rotate-x "rotateX" [Angle] [angle]] + [rotate-y "rotateY" [Angle] [angle]] + [rotate-z "rotateZ" [Angle] [angle]] + + [skew "skew" [Angle Angle] [x-angle y-angle]] + [skew-x "skewX" [Angle] [angle]] + [skew-y "skewY" [Angle] [angle]] + ) + + (def: #export (rotate-3d [x y z angle]) + (-> [Frac Frac Frac Angle] (Value Transform)) + (..apply "rotate3d" + (list (%number x) (%number y) (%number z) (..angle angle)))) + + (def: origin-separator " ") + + (def: #export (origin-2d x y) + (-> (Value Length) (Value Length) (Value Transform-Origin)) + (:abstraction (format (:representation x) ..origin-separator + (:representation y)))) + + (def: #export (origin-3d x y z) + (-> (Value Length) (Value Length) (Value Length) (Value Transform-Origin)) + (:abstraction (format (:representation x) ..origin-separator + (:representation y) ..origin-separator + (:representation z)))) + + (def: #export vertical-align + (-> (Value Length) (Value Vertical-Align)) + (|>> :transmutation)) + + (def: #export (z-index index) + (-> Int (Value Z-Index)) + (:abstraction (if (i.< +0 index) + (%.int index) + (%.nat (.nat index))))) + + (multi: multi-image Image ",") + (multi: multi-shadow Shadow ",") + (multi: multi-content Content " ") + ) diff --git a/stdlib/source/library/lux/data/format/html.lux b/stdlib/source/library/lux/data/format/html.lux new file mode 100644 index 000000000..6a8e0b24f --- /dev/null +++ b/stdlib/source/library/lux/data/format/html.lux @@ -0,0 +1,563 @@ +(.module: + [library + [lux (#- Meta Source comment and) + ["." function] + [data + ["." product] + ["." maybe ("#\." functor)] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [type + abstract] + [host + ["." js]] + [macro + ["." template]] + [world + [net (#+ URL)]]]] + [// + [css + ["." selector] + ["." style (#+ Style)]] + ["." xml (#+ XML)]]) + +(type: #export Tag selector.Tag) +(type: #export ID selector.ID) +(type: #export Class selector.Class) + +(type: #export Attributes + {#.doc "Attributes for an HTML tag."} + (List [Text Text])) + +(type: #export Script js.Statement) + +(type: #export Target + #Blank + #Parent + #Self + #Top + (#Frame Text)) + +(def: (target value) + (-> Target Text) + (case value + #Blank "_blank" + #Parent "_parent" + #Self "_self" + #Top "_top" + (#Frame name) name)) + +(def: sanitize + {#.doc "Properly formats text to ensure no injection can happen on the HTML."} + (-> Text Text) + (|>> (text.replace-all "&" "&") + (text.replace-all "<" "<") + (text.replace-all ">" ">") + (text.replace-all text.double-quote """) + (text.replace-all "'" "'") + (text.replace-all "/" "/"))) + +(def: attributes + (-> Attributes Text) + (|>> (list\map (function (_ [key val]) + (format key "=" text.double-quote (..sanitize val) text.double-quote))) + (text.join-with " "))) + +(def: (open tag attributes) + (-> Tag Attributes Text) + (|> attributes + ..attributes + (format tag " ") + (text.enclose ["<" ">"]))) + +(def: close + (-> Tag Text) + (text.enclose ["</" ">"])) + +(abstract: #export (HTML brand) + Text + + (template [<name> <brand>] + [(abstract: #export <brand> Any) + (type: #export <name> (HTML <brand>))] + + [Meta Meta'] + [Head Head'] + [Item Item'] + [Option Option'] + [Input Input'] + [Cell Cell'] + [Header Header'] + [Row Row'] + [Column Column'] + [Parameter Parameter'] + [Body Body'] + [Document Document'] + ) + + (template [<super> <super-raw> <sub>+] + [(abstract: #export (<super-raw> brand) Any) + (type: #export <super> (HTML (<super-raw> Any))) + + (`` (template [<sub> <sub-raw>] + [(abstract: #export <sub-raw> Any) + (type: #export <sub> (HTML (<super-raw> <sub-raw>)))] + + (~~ (template.splice <sub>+))))] + + [Element Element' + [[Content Content'] + [Image Image']]] + + [Media Media' + [[Source Source'] + [Track Track']]] + ) + + (def: #export html + (-> Document Text) + (|>> :representation)) + + (def: #export (and pre post) + (All [brand] (-> (HTML brand) (HTML brand) (HTML brand))) + (:abstraction (format (:representation pre) (:representation post)))) + + (def: #export (comment content node) + (All [brand] (-> Text (HTML brand) (HTML brand))) + (:abstraction + (format (text.enclose ["<!--" "-->"] content) + (:representation node)))) + + (def: (empty name attributes) + (-> Tag Attributes HTML) + (:abstraction + (format (..open name attributes) + (..close name)))) + + (def: (simple tag attributes) + (-> Tag Attributes HTML) + (|> attributes + (..open tag) + :abstraction)) + + (def: (tag name attributes content) + (-> Tag Attributes (HTML Any) HTML) + (:abstraction + (format (..open name attributes) + (:representation content) + (..close name)))) + + (def: (raw tag attributes content) + (-> Text Attributes Text HTML) + (:abstraction + (format (..open tag attributes) + content + (..close tag)))) + + (template [<name> <tag> <brand>] + [(def: #export <name> + (-> Attributes <brand>) + (..simple <tag>))] + + [link "link" Meta] + [meta "meta" Meta] + [input "input" Input] + [embedded "embed" Element] + [column "col" Column] + [parameter "param" Parameter] + ) + + (def: #export (base href target) + (-> URL (Maybe Target) Meta) + (let [partial (list ["href" href]) + full (case target + (#.Some target) + (list& ["target" (..target target)] partial) + + #.None + partial)] + (..simple "base" full))) + + (def: #export style + (-> Style Meta) + (|>> style.inline (..raw "style" (list)))) + + (def: #export (script attributes inline) + (-> Attributes (Maybe Script) Meta) + (|> inline + (maybe\map js.code) + (maybe.default "") + (..raw "script" attributes))) + + (def: #export text + (-> Text Content) + (|>> ..sanitize + :abstraction)) + + (template [<tag> <alias> <name>] + [(def: #export <name> + Element + (..simple <tag> (list))) + + (def: #export <alias> <name>)] + ["br" br line-break] + ["wbr" wbr word-break] + ["hr" hr separator] + ) + + (def: #export (image source attributes) + (-> URL Attributes Image) + (|> attributes + (#.Cons ["src" source]) + (..simple "img"))) + + (def: #export (svg attributes content) + (-> Attributes XML Element) + (|> content + (\ xml.codec encode) + (..raw "svg" attributes))) + + (type: #export Coord + {#horizontal Nat + #vertical Nat}) + + (def: metric-separator ",") + (def: coord-separator ",") + + (def: (%coord [horizontal vertical]) + (Format Coord) + (format (%.nat horizontal) ..metric-separator (%.nat vertical))) + + (type: #export Rectangle + {#start Coord + #end Coord}) + + (type: #export Circle + {#center Coord + #radius Nat}) + + (type: #export Polygon + {#first Coord + #second Coord + #third Coord + #extra (List Coord)}) + + (def: (%rectangle [start end]) + (Format Rectangle) + (format (%coord start) ..coord-separator (%coord end))) + + (def: (%circle [center radius]) + (Format Circle) + (format (%coord center) ..metric-separator (%.nat radius))) + + (def: (%polygon [first second third extra]) + (Format Polygon) + (|> (list& first second third extra) + (list\map %coord) + (text.join-with ..coord-separator))) + + (type: #export Shape + (#Rectangle Rectangle) + (#Circle Circle) + (#Polygon Polygon)) + + (template [<name> <shape> <type> <format>] + [(def: (<name> attributes shape) + (-> Attributes <type> (HTML Any)) + (..simple "area" (list& ["shape" <shape>] + ["coords" (<format> shape)] + attributes)))] + + [rectangle "rect" Rectangle ..%rectangle] + [circle "circle" Circle ..%circle] + [polygon "poly" Polygon ..%polygon] + ) + + (def: (area attributes shape) + (-> Attributes Shape (HTML Any)) + (case shape + (#Rectangle rectangle) + (..rectangle attributes rectangle) + + (#Circle circle) + (..circle attributes circle) + + (#Polygon polygon) + (..polygon attributes polygon))) + + (def: #export (map attributes areas for) + (-> Attributes (List [Attributes Shape]) Image Image) + ($_ ..and + for + (case (list\map (product.uncurry ..area) areas) + #.Nil + (..empty "map" attributes) + + (#.Cons head tail) + (..tag "map" attributes + (list\fold (function.flip ..and) head tail))))) + + (template [<name> <tag> <type>] + [(def: #export <name> + (-> Attributes <type>) + (..empty <tag>))] + + [canvas "canvas" Element] + [progress "progress" Element] + [output "output" Input] + [source "source" Source] + [track "track" Track] + ) + + (template [<name> <tag>] + [(def: #export (<name> attributes media on-unsupported) + (-> Attributes Media (Maybe Content) Element) + (..tag <tag> attributes + (|> on-unsupported + (maybe.default (..text "")) + (..and media))))] + + [audio "audio"] + [video "video"] + ) + + (def: #export (picture attributes sources image) + (-> Attributes Source Image Element) + (..tag "picture" attributes (..and sources image))) + + (def: #export (anchor href attributes content) + (-> URL Attributes Element Element) + (..tag "a" (list& ["href" href] attributes) content)) + + (def: #export label + (-> ID Input) + (|>> ["for"] list (..empty "label"))) + + (template [<name> <container-tag> <description-tag> <type>] + [(def: #export (<name> description attributes content) + (-> (Maybe Content) Attributes <type> <type>) + (..tag <container-tag> attributes + (case description + (#.Some description) + ($_ ..and + (..tag <description-tag> (list) description) + content) + + #.None + content)))] + + [details "details" "summary" Element] + [field-set "fieldset" "legend" Input] + [figure "figure" "figcaption" Element] + ) + + (template [<name> <tag> <type>] + [(def: #export (<name> attributes content) + (-> Attributes (Maybe Content) <type>) + (|> content + (maybe.default (..text "")) + (..tag <tag> attributes)))] + + [text-area "textarea" Input] + [iframe "iframe" Element] + ) + + (type: #export Phrase (-> Attributes Content Element)) + + (template [<name> <tag>] + [(def: #export <name> + Phrase + (..tag <tag>))] + + [abbrebiation "abbr"] + [block-quote "blockquote"] + [bold "b"] + [cite "cite"] + [code "code"] + [definition "dfn"] + [deleted "del"] + [emphasized "em"] + [h1 "h1"] + [h2 "h2"] + [h3 "h3"] + [h4 "h4"] + [h5 "h5"] + [h6 "h6"] + [inserted "ins"] + [italic "i"] + [keyboard "kbd"] + [marked "mark"] + [meter "meter"] + [pre "pre"] + [quote "q"] + [sample "samp"] + [struck "s"] + [small "small"] + [sub "sub"] + [super "sup"] + [strong "strong"] + [time "time"] + [underlined "u"] + [variable "var"] + ) + + (def: #export incorrect ..struck) + + (def: (ruby-pronunciation pronunciation) + (-> Content (HTML Any)) + (..tag "rt" (list) + ($_ ..and + (..tag "rp" (list) (..text "(")) + pronunciation + (..tag "rp" (list) (..text ")"))))) + + (def: #export (ruby attributes content pronunciation) + (-> Attributes Content Content Element) + (..tag "ruby" attributes + ($_ ..and + content + (ruby-pronunciation pronunciation)))) + + (type: #export Composite (-> Attributes Element Element)) + + (template [<name> <tag>] + [(def: #export <name> + Composite + (..tag <tag>))] + + [article "article"] + [aside "aside"] + [dialog "dialog"] + [div "div"] + [footer "footer"] + [header "header"] + [main "main"] + [navigation "nav"] + [paragraph "p"] + [section "section"] + [span "span"] + ) + + (template [<tag> <name> <input>] + [(def: <name> + (-> <input> (HTML Any)) + (..tag <tag> (list)))] + + ["dt" term Content] + ["dd" description Element] + ) + + (def: #export (description-list attributes descriptions) + (-> Attributes (List [Content Element]) Element) + (case (list\map (function (_ [term description]) + ($_ ..and + (..term term) + (..description description))) + descriptions) + #.Nil + (..empty "dl" attributes) + + (#.Cons head tail) + (..tag "dl" attributes + (list\fold (function.flip ..and) head tail)))) + + (def: #export p ..paragraph) + + (template [<name> <tag> <input> <output>] + [(def: #export <name> + (-> Attributes <input> <output>) + (..tag <tag>))] + + [button "button" Element Input] + [item "li" Element Item] + [ordered-list "ol" Item Element] + [unordered-list "ul" Item Element] + [option "option" Content Option] + [option-group "optgroup" Option Option] + [data-list "datalist" Option Element] + [select "select" Option Input] + [address "address" Element Element] + [form "form" Input Element] + [data "data" Element Element] + [object "object" Parameter Element] + ) + + (template [<name> <tag> <input> <output>] + [(def: #export <name> + (-> <input> <output>) + (..tag <tag> (list)))] + + [title "title" Content Meta] + [no-script "noscript" Content Meta] + [template "template" (HTML Any) (HTML Nothing)] + [table-header "th" Element Header] + [table-cell "td" Element Cell] + [head "head" Meta Head] + [body "body" Element Body] + ) + + (template [<name> <tag> <input> <output>] + [(def: <name> + (-> <input> <output>) + (..tag <tag> (list)))] + + [table-row "tr" (HTML Any) Row] + [table-head "thead" Row HTML] + [table-body "tbody" Row HTML] + [table-foot "tfoot" Row HTML] + [columns-group "colgroup" Column HTML] + ) + + (def: #export (table attributes caption columns headers rows footer) + (-> Attributes (Maybe Content) (Maybe Column) Header (List Cell) (Maybe Cell) Element) + (let [head (..table-head (..table-row headers)) + content (case (list\map table-row rows) + #.Nil + head + + (#.Cons first rest) + (..and head + (..table-body + (list\fold (function.flip ..and) first rest)))) + content (case footer + #.None + content + + (#.Some footer) + (..and content + (..table-foot (..table-row footer)))) + content (case columns + #.None + content + + (#.Some columns) + (..and (..columns-group columns) + content)) + content (case caption + #.None + content + + (#.Some caption) + (..and (:as HTML caption) + content))] + (..tag "table" attributes + content))) + + (template [<name> <doc-type>] + [(def: #export <name> + (-> Head Body Document) + (let [doc-type <doc-type>] + (function (_ head body) + (|> (..tag "html" (list) (..and head body)) + :representation + (format doc-type) + :abstraction))))] + + [html-5 "<!DOCTYPE html>"] + [html-4_01 (format "<!DOCTYPE HTML PUBLIC " text.double-quote "-//W3C//DTD HTML 4.01//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/html4/strict.dtd" text.double-quote ">")] + [xhtml-1_0 (format "<!DOCTYPE html PUBLIC " text.double-quote "-//W3C//DTD XHTML 1.0 Strict//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd" text.double-quote ">")] + [xhtml-1_1 (format "<!DOCTYPE html PUBLIC " text.double-quote "-//W3C//DTD XHTML 1.1//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd" text.double-quote ">")] + ) + ) diff --git a/stdlib/source/library/lux/data/format/json.lux b/stdlib/source/library/lux/data/format/json.lux new file mode 100644 index 000000000..142a15610 --- /dev/null +++ b/stdlib/source/library/lux/data/format/json.lux @@ -0,0 +1,422 @@ +(.module: {#.doc (.doc "Functionality for reading and writing values in the JSON format." + "For more information, please see: http://www.json.org/")} + [library + [lux #* + ["." meta (#+ monad)] + [abstract + [equivalence (#+ Equivalence)] + [codec (#+ Codec)] + [predicate (#+ Predicate)] + ["." monad (#+ do)]] + [control + pipe + ["." try (#+ Try)] + ["<>" parser ("#\." monad) + ["<.>" text (#+ Parser)]]] + [data + ["." bit] + ["." maybe] + ["." product] + ["." text ("#\." equivalence monoid)] + [collection + ["." list ("#\." fold functor)] + ["." row (#+ Row row) ("#\." monad)] + ["." dictionary (#+ Dictionary)]]] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code]] + [math + [number + ["n" nat] + ["f" frac ("#\." decimal)]]]]]) + +(template [<name> <type>] + [(type: #export <name> + <type>)] + + [Null Any] + [Boolean Bit] + [Number Frac] + [String Text] + ) + +(type: #export #rec JSON + (#Null Null) + (#Boolean Boolean) + (#Number Number) + (#String String) + (#Array (Row JSON)) + (#Object (Dictionary String JSON))) + +(template [<name> <type>] + [(type: #export <name> + <type>)] + + [Array (Row JSON)] + [Object (Dictionary String JSON)] + ) + +(def: #export null? + (Predicate JSON) + (|>> (case> #Null true + _ false))) + +(def: #export object + (-> (List [String JSON]) JSON) + (|>> (dictionary.from_list text.hash) #..Object)) + +(syntax: #export (json token) + {#.doc (doc "A simple way to produce JSON literals." + (json #null) + (json #1) + (json +123.456) + (json "this is a string") + (json ["this" "is" "an" "array"]) + (json {"this" "is" + "an" "object"}))} + (let [(^open ".") ..monad + wrapper (function (_ x) (` (..json (~ x))))] + (case token + (^template [<ast_tag> <ctor> <json_tag>] + [[_ (<ast_tag> value)] + (wrap (list (` (: JSON (<json_tag> (~ (<ctor> value)))))))]) + ([#.Bit code.bit #..Boolean] + [#.Frac code.frac #..Number] + [#.Text code.text #..String]) + + [_ (#.Tag ["" "null"])] + (wrap (list (` (: JSON #..Null)))) + + [_ (#.Tuple members)] + (wrap (list (` (: JSON (#..Array ((~! row) (~+ (list\map wrapper members)))))))) + + [_ (#.Record pairs)] + (do {! ..monad} + [pairs' (monad.map ! + (function (_ [slot value]) + (case slot + [_ (#.Text key_name)] + (wrap (` [(~ (code.text key_name)) (~ (wrapper value))])) + + _ + (meta.fail "Wrong syntax for JSON object."))) + pairs)] + (wrap (list (` (: JSON (#..Object ((~! dictionary.from_list) + (~! text.hash) + (list (~+ pairs'))))))))) + + _ + (wrap (list token))))) + +(def: #export (fields json) + {#.doc "Get all the fields in a JSON object."} + (-> JSON (Try (List String))) + (case json + (#Object obj) + (#try.Success (dictionary.keys obj)) + + _ + (#try.Failure ($_ text\compose "Cannot get the fields of a non-object.")))) + +(def: #export (get key json) + {#.doc "A JSON object field getter."} + (-> String JSON (Try JSON)) + (case json + (#Object obj) + (case (dictionary.get key obj) + (#.Some value) + (#try.Success value) + + #.None + (#try.Failure ($_ text\compose "Missing field '" key "' on object."))) + + _ + (#try.Failure ($_ text\compose "Cannot get field '" key "' on a non-object.")))) + +(def: #export (set key value json) + {#.doc "A JSON object field setter."} + (-> String JSON JSON (Try JSON)) + (case json + (#Object obj) + (#try.Success (#Object (dictionary.put key value obj))) + + _ + (#try.Failure ($_ text\compose "Cannot set field '" key "' on a non-object.")))) + +(template [<name> <tag> <type> <desc>] + [(def: #export (<name> key json) + {#.doc (code.text ($_ text\compose "A JSON object field getter for " <desc> "."))} + (-> Text JSON (Try <type>)) + (case (get key json) + (#try.Success (<tag> value)) + (#try.Success value) + + (#try.Success _) + (#try.Failure ($_ text\compose "Wrong value type at key: " key)) + + (#try.Failure error) + (#try.Failure error)))] + + [get_boolean #Boolean Boolean "booleans"] + [get_number #Number Number "numbers"] + [get_string #String String "strings"] + [get_array #Array Array "arrays"] + [get_object #Object Object "objects"] + ) + +(implementation: #export equivalence + (Equivalence JSON) + + (def: (= x y) + (case [x y] + [#Null #Null] + #1 + + (^template [<tag> <struct>] + [[(<tag> x') (<tag> y')] + (\ <struct> = x' y')]) + ([#Boolean bit.equivalence] + [#Number f.equivalence] + [#String text.equivalence]) + + [(#Array xs) (#Array ys)] + (and (n.= (row.size xs) (row.size ys)) + (list\fold (function (_ idx prev) + (and prev + (maybe.default #0 + (do maybe.monad + [x' (row.nth idx xs) + y' (row.nth idx ys)] + (wrap (= x' y')))))) + #1 + (list.indices (row.size xs)))) + + [(#Object xs) (#Object ys)] + (and (n.= (dictionary.size xs) (dictionary.size ys)) + (list\fold (function (_ [xk xv] prev) + (and prev + (case (dictionary.get xk ys) + #.None #0 + (#.Some yv) (= xv yv)))) + #1 + (dictionary.entries xs))) + + _ + #0))) + +############################################################ +############################################################ +############################################################ + +(def: (format_null _) + (-> Null Text) + "null") + +(def: format_boolean + (-> Boolean Text) + (|>> (case> + #0 "false" + #1 "true"))) + +(def: format_number + (-> Number Text) + (|>> (case> + (^or +0.0 -0.0) "0.0" + value (let [raw (\ f.decimal encode value)] + (if (f.< +0.0 value) + raw + (|> raw (text.split 1) maybe.assume product.right)))))) + +(def: escape "\") +(def: escaped_dq (text\compose ..escape text.double_quote)) + +(def: format_string + (-> String Text) + (|>> (text.replace_all text.double_quote ..escaped_dq) + (text.enclose [text.double_quote text.double_quote]))) + +(template [<token> <name>] + [(def: <name> + Text + <token>)] + + ["," separator] + [":" entry_separator] + + ["[" open_array] + ["]" close_array] + + ["{" open_object] + ["}" close_object] + ) + +(def: (format_array format) + (-> (-> JSON Text) (-> Array Text)) + (|>> (row\map format) + row.to_list + (text.join_with ..separator) + (text.enclose [..open_array ..close_array]))) + +(def: (format_kv format [key value]) + (-> (-> JSON Text) (-> [String JSON] Text)) + ($_ text\compose + (..format_string key) + ..entry_separator + (format value) + )) + +(def: (format_object format) + (-> (-> JSON Text) (-> Object Text)) + (|>> dictionary.entries + (list\map (..format_kv format)) + (text.join_with ..separator) + (text.enclose [..open_object ..close_object]))) + +(def: #export (format json) + (-> JSON Text) + (case json + (^template [<tag> <format>] + [(<tag> value) + (<format> value)]) + ([#Null ..format_null] + [#Boolean ..format_boolean] + [#Number ..format_number] + [#String ..format_string] + [#Array (..format_array format)] + [#Object (..format_object format)]) + )) + +############################################################ +############################################################ +############################################################ + +(def: parse_space + (Parser Text) + (<text>.some <text>.space)) + +(def: parse_separator + (Parser [Text Any Text]) + ($_ <>.and + ..parse_space + (<text>.this ..separator) + ..parse_space)) + +(def: parse_null + (Parser Null) + (do <>.monad + [_ (<text>.this "null")] + (wrap []))) + +(template [<name> <token> <value>] + [(def: <name> + (Parser Boolean) + (do <>.monad + [_ (<text>.this <token>)] + (wrap <value>)))] + + [parse_true "true" #1] + [parse_false "false" #0] + ) + +(def: parse_boolean + (Parser Boolean) + ($_ <>.either + ..parse_true + ..parse_false)) + +(def: parse_number + (Parser Number) + (do {! <>.monad} + [signed? (<>.parses? (<text>.this "-")) + digits (<text>.many <text>.decimal) + decimals (<>.default "0" + (do ! + [_ (<text>.this ".")] + (<text>.many <text>.decimal))) + exp (<>.default "" + (do ! + [mark (<text>.one_of "eE") + signed?' (<>.parses? (<text>.this "-")) + offset (<text>.many <text>.decimal)] + (wrap ($_ text\compose mark (if signed?' "-" "") offset))))] + (case (f\decode ($_ text\compose (if signed? "-" "") digits "." decimals exp)) + (#try.Failure message) + (<>.fail message) + + (#try.Success value) + (wrap value)))) + +(def: parse_escaped + (Parser Text) + ($_ <>.either + (<>.after (<text>.this "\t") + (<>\wrap text.tab)) + (<>.after (<text>.this "\b") + (<>\wrap text.back_space)) + (<>.after (<text>.this "\n") + (<>\wrap text.new_line)) + (<>.after (<text>.this "\r") + (<>\wrap text.carriage_return)) + (<>.after (<text>.this "\f") + (<>\wrap text.form_feed)) + (<>.after (<text>.this (text\compose "\" text.double_quote)) + (<>\wrap text.double_quote)) + (<>.after (<text>.this "\\") + (<>\wrap "\")))) + +(def: parse_string + (Parser String) + (<| (<text>.enclosed [text.double_quote text.double_quote]) + (loop [_ []]) + (do {! <>.monad} + [chars (<text>.some (<text>.none_of (text\compose "\" text.double_quote))) + stop <text>.peek]) + (if (text\= "\" stop) + (do ! + [escaped parse_escaped + next_chars (recur [])] + (wrap ($_ text\compose chars escaped next_chars))) + (wrap chars)))) + +(def: (parse_kv parse_json) + (-> (Parser JSON) (Parser [String JSON])) + (do <>.monad + [key ..parse_string + _ ..parse_space + _ (<text>.this ..entry_separator) + _ ..parse_space + value parse_json] + (wrap [key value]))) + +(template [<name> <type> <open> <close> <elem_parser> <prep>] + [(def: (<name> parse_json) + (-> (Parser JSON) (Parser <type>)) + (do <>.monad + [_ (<text>.this <open>) + _ parse_space + elems (<>.separated_by ..parse_separator <elem_parser>) + _ parse_space + _ (<text>.this <close>)] + (wrap (<prep> elems))))] + + [parse_array Array ..open_array ..close_array parse_json row.from_list] + [parse_object Object ..open_object ..close_object (parse_kv parse_json) (dictionary.from_list text.hash)] + ) + +(def: parse_json + (Parser JSON) + (<>.rec + (function (_ parse_json) + ($_ <>.or + parse_null + parse_boolean + parse_number + parse_string + (parse_array parse_json) + (parse_object parse_json))))) + +(implementation: #export codec + (Codec Text JSON) + + (def: encode ..format) + (def: decode (<text>.run parse_json))) diff --git a/stdlib/source/library/lux/data/format/markdown.lux b/stdlib/source/library/lux/data/format/markdown.lux new file mode 100644 index 000000000..05a8ed94a --- /dev/null +++ b/stdlib/source/library/lux/data/format/markdown.lux @@ -0,0 +1,181 @@ +(.module: + [library + [lux (#- and) + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)]]] + [type + abstract] + [world + [net (#+ URL)]]]]) + +## https://www.markdownguide.org/basic-syntax/ + +(def: sanitize + (-> Text Text) + (|>> (text.replace-all "\" "\\") + (text.replace-all "`" "\`") + (text.replace-all "*" "\*") + (text.replace-all "_" "\_") + (text.replace-all "{" "\{") + (text.replace-all "}" "\}") + (text.replace-all "[" "\[") + (text.replace-all "]" "\]") + (text.replace-all "(" "\(") + (text.replace-all ")" "\)") + (text.replace-all "#" "\#") + (text.replace-all "+" "\+") + (text.replace-all "-" "\-") + (text.replace-all "." "\.") + (text.replace-all "!" "\!"))) + +(abstract: #export Span Any) +(abstract: #export Block Any) + +(abstract: #export (Markdown brand) + Text + + (def: #export empty + Markdown + (:abstraction "")) + + (def: #export text + (-> Text (Markdown Span)) + (|>> ..sanitize :abstraction)) + + (def: blank-line (format text.new-line text.new-line)) + + (template [<name> <prefix>] + [(def: #export (<name> content) + (-> Text Markdown) + (:abstraction (format <prefix> " " (..sanitize content) ..blank-line)))] + + [heading/1 "#"] + [heading/2 "##"] + [heading/3 "###"] + [heading/4 "####"] + [heading/5 "#####"] + [heading/6 "######"] + ) + + (def: (block content) + (-> Text (Markdown Block)) + (:abstraction (format content ..blank-line))) + + (def: #export paragraph + (-> (Markdown Span) (Markdown Block)) + (|>> :representation ..block)) + + (def: #export break + (Markdown Span) + (:abstraction (format " " text.new-line))) + + (template [<name> <wrapper>] + [(def: #export <name> + (-> (Markdown Span) (Markdown Span)) + (|>> :representation + (text.enclose [<wrapper> <wrapper>]) + :abstraction))] + + [bold "**"] + [italic "_"] + ) + + (def: (prefix with) + (-> Text (-> Text Text)) + (|>> (text.split-all-with text.new-line) + (list\map (function (_ line) + (if (text.empty? line) + line + (format with line)))) + (text.join-with text.new-line))) + + (def: indent + (-> Text Text) + (..prefix text.tab)) + + (def: #export quote + (-> (Markdown Block) (Markdown Block)) + (|>> :representation + (..prefix "> ") + :abstraction)) + + (def: #export numbered-list + (-> (List [(Markdown Span) (Maybe (Markdown Block))]) + (Markdown Block)) + (|>> list.enumeration + (list\map (function (_ [idx [summary detail]]) + (format (%.nat (inc idx)) ". " (:representation summary) text.new-line + (case detail + (#.Some detail) + (|> detail :representation ..indent (text.enclose [text.new-line text.new-line])) + + #.None + "")))) + (text.join-with text.new-line) + ..block)) + + (def: #export bullet-list + (-> (List [(Markdown Span) (Maybe (Markdown Block))]) + (Markdown Block)) + (|>> (list\map (function (_ [summary detail]) + (format "*. " (:representation summary) text.new-line + (case detail + (#.Some detail) + (|> detail :representation ..indent (text.enclose [text.new-line text.new-line])) + + #.None + "")))) + (text.join-with text.new-line) + ..block)) + + (def: #export snippet + {#.doc "A snippet of code."} + (-> Text (Markdown Span)) + (|>> ..sanitize (text.enclose ["`" "`"]) :abstraction)) + + (def: #export code + {#.doc "A block of code."} + (-> Text (Markdown Block)) + (let [open (format "```" text.new-line) + close (format text.new-line "```")] + (|>> (text.enclose [open close]) ..block))) + + (def: #export (image description url) + (-> Text URL (Markdown Span)) + (:abstraction (format "![" (..sanitize description) "](" url ")"))) + + (def: #export horizontal-rule + (Markdown Block) + (..block "___")) + + (def: #export (link description url) + (-> (Markdown Span) URL (Markdown Span)) + (:abstraction (format "[" (:representation description) "](" url ")"))) + + (type: #export Email Text) + + (template [<name> <type>] + [(def: #export <name> + (-> <type> (Markdown Span)) + (|>> (text.enclose ["<" ">"]) :abstraction))] + + [url URL] + [email Email] + ) + + (template [<name> <brand> <infix>] + [(def: #export (<name> pre post) + (-> (Markdown <brand>) (Markdown <brand>) (Markdown <brand>)) + (:abstraction (format (:representation pre) <infix> (:representation post))))] + + [and Span " "] + [then Block ""] + ) + + (def: #export markdown + (-> (Markdown Any) Text) + (|>> :representation)) + ) diff --git a/stdlib/source/library/lux/data/format/tar.lux b/stdlib/source/library/lux/data/format/tar.lux new file mode 100644 index 000000000..f95b29334 --- /dev/null +++ b/stdlib/source/library/lux/data/format/tar.lux @@ -0,0 +1,871 @@ +(.module: + [library + [lux (#- Mode Name and) + [abstract + [monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser + ["<b>" binary (#+ Parser)]]] + [data + ["." product] + ["." binary (#+ Binary)] + ["." text (#+ Char) + ["%" format (#+ format)] + [encoding + ["." utf8]]] + ["." format #_ + ["#" binary (#+ Writer) ("#\." monoid)]] + [collection + ["." list ("#\." fold)] + ["." row (#+ Row) ("#\." fold)]]] + [math + ["." number + ["n" nat] + ["." i64]]] + [time + ["." instant (#+ Instant)] + ["." duration]] + [world + ["." file]] + [type + abstract]]]) + +(type: Size Nat) + +(def: octal_size Size 8) + +(def: (octal_padding max_size number) + (-> Size Text Text) + (let [padding_size (n.- (text.size number) + max_size) + padding (|> "0" + (list.repeat padding_size) + (text.join_with ""))] + (format padding number))) + +(def: blank " ") +(def: null text.null) + +(def: small_size Size 6) +(def: big_size Size 11) + +(template [<exception> <limit> <size> + <type> <in> <out> <writer> <suffix> + <coercion>] + [(def: #export <limit> + Nat + (|> ..octal_size + (list.repeat <size>) + (list\fold n.* 1) + inc)) + + (exception: #export (<exception> {value Nat}) + (exception.report + ["Value" (%.nat value)] + ["Maximum" (%.nat (dec <limit>))])) + + (abstract: #export <type> + Nat + + (def: #export (<in> value) + (-> Nat (Try <type>)) + (if (n.< <limit> value) + (#try.Success (:abstraction value)) + (exception.throw <exception> [value]))) + + (def: #export <out> + (-> <type> Nat) + (|>> :representation)) + + (def: <writer> + (Writer <type>) + (let [suffix <suffix> + padded_size (n.+ (text.size suffix) <size>)] + (|>> :representation + (\ n.octal encode) + (..octal_padding <size>) + (text.suffix suffix) + (\ utf8.codec encode) + (format.segment padded_size)))) + + (def: <coercion> + (-> Nat <type>) + (|>> (n.% <limit>) + :abstraction)) + )] + + [not_a_small_number small_limit ..small_size + Small small from_small + small_writer (format ..blank ..null) + coerce_small] + [not_a_big_number big_limit ..big_size + Big big from_big + big_writer ..blank + coerce_big] + ) + +(exception: #export (wrong_character {expected Char} {actual Char}) + (exception.report + ["Expected" (%.nat expected)] + ["Actual" (%.nat actual)])) + +(def: verify_small_suffix + (Parser Any) + (do <>.monad + [pre_end <b>.bits/8 + end <b>.bits/8 + _ (let [expected (`` (char (~~ (static ..blank))))] + (<>.assert (exception.construct ..wrong_character [expected pre_end]) + (n.= expected pre_end))) + _ (let [expected (`` (char (~~ (static ..null))))] + (<>.assert (exception.construct ..wrong_character [expected end]) + (n.= expected end)))] + (wrap []))) + +(def: small_parser + (Parser Small) + (do <>.monad + [digits (<b>.segment ..small_size) + digits (<>.lift (\ utf8.codec decode digits)) + _ ..verify_small_suffix] + (<>.lift + (do {! try.monad} + [value (\ n.octal decode digits)] + (..small value))))) + +(def: big_parser + (Parser Big) + (do <>.monad + [digits (<b>.segment ..big_size) + digits (<>.lift (\ utf8.codec decode digits)) + end <b>.bits/8 + _ (let [expected (`` (char (~~ (static ..blank))))] + (<>.assert (exception.construct ..wrong_character [expected end]) + (n.= expected end)))] + (<>.lift + (do {! try.monad} + [value (\ n.octal decode digits)] + (..big value))))) + +(abstract: Checksum + Text + + (def: from_checksum + (-> Checksum Text) + (|>> :representation)) + + (def: dummy_checksum + Checksum + (:abstraction " ")) + + (def: checksum_suffix + (format ..blank ..null)) + + (def: checksum + (-> Binary Nat) + (binary.fold n.+ 0)) + + (def: checksum_checksum + (|> ..dummy_checksum + :representation + (\ utf8.codec encode) + ..checksum)) + + (def: checksum_code + (-> Binary Checksum) + (|>> ..checksum + ..coerce_small + ..from_small + (\ n.octal encode) + (..octal_padding ..small_size) + (text.suffix ..checksum_suffix) + :abstraction)) + + (def: checksum_writer + (Writer Checksum) + (let [padded_size (n.+ (text.size ..checksum_suffix) + ..small_size)] + (|>> :representation + (\ utf8.codec encode) + (format.segment padded_size)))) + + (def: checksum_parser + (Parser [Nat Checksum]) + (do <>.monad + [ascii (<b>.segment ..small_size) + digits (<>.lift (\ utf8.codec decode ascii)) + _ ..verify_small_suffix + value (<>.lift + (\ n.octal decode digits))] + (wrap [value + (:abstraction (format digits ..checksum_suffix))]))) + ) + +(def: last_ascii + Char + (number.hex "007F")) + +(def: ascii? + (-> Text Bit) + (|>> (\ utf8.codec encode) + (binary.fold (function (_ char verdict) + (.and verdict + (n.<= ..last_ascii char))) + true))) + +(exception: #export (not_ascii {text Text}) + (exception.report + ["Text" (%.text text)])) + +(def: #export name_size Size 31) +(def: #export path_size Size 99) + +(def: (un_pad string) + (-> Binary (Try Binary)) + (case (binary.size string) + 0 (#try.Success string) + size (loop [end (dec size)] + (case end + 0 (#try.Success (\ utf8.codec encode "")) + _ (do try.monad + [last_char (binary.read/8 end string)] + (`` (case (.nat last_char) + (^ (char (~~ (static ..null)))) + (recur (dec end)) + + _ + (binary.slice 0 (inc end) string)))))))) + +(template [<type> <representation> <size> <exception> <in> <out> <writer> <parser> <none>] + [(abstract: #export <type> + <representation> + + (exception: #export (<exception> {value Text}) + (exception.report + ["Value" (%.text value)] + ["Size" (%.nat (text.size value))] + ["Maximum" (%.nat <size>)])) + + (def: #export (<in> value) + (-> <representation> (Try <type>)) + (if (..ascii? value) + (if (|> value (\ utf8.codec encode) binary.size (n.<= <size>)) + (#try.Success (:abstraction value)) + (exception.throw <exception> [value])) + (exception.throw ..not_ascii [value]))) + + (def: #export <out> + (-> <type> <representation>) + (|>> :representation)) + + (def: <writer> + (Writer <type>) + (let [suffix ..null + padded_size (n.+ (text.size suffix) <size>)] + (|>> :representation + (text.suffix suffix) + (\ utf8.codec encode) + (format.segment padded_size)))) + + (def: <parser> + (Parser <type>) + (do <>.monad + [string (<b>.segment <size>) + end <b>.bits/8 + #let [expected (`` (char (~~ (static ..null))))] + _ (<>.assert (exception.construct ..wrong_character [expected end]) + (n.= expected end))] + (<>.lift + (do {! try.monad} + [ascii (..un_pad string) + text (\ utf8.codec decode ascii)] + (<in> text))))) + + (def: #export <none> + <type> + (try.assume (<in> ""))) + )] + + [Name Text ..name_size name_is_too_long name from_name name_writer name_parser anonymous] + [Path file.Path ..path_size path_is_too_long path from_path path_writer path_parser no_path] + ) + +(def: magic_size Size 7) + +(abstract: Magic + Text + + (def: ustar (:abstraction "ustar ")) + + (def: from_magic + (-> Magic Text) + (|>> :representation)) + + (def: magic_writer + (Writer Magic) + (let [padded_size (n.+ (text.size ..null) + ..magic_size)] + (|>> :representation + (\ utf8.codec encode) + (format.segment padded_size)))) + + (def: magic_parser + (Parser Magic) + (do <>.monad + [string (<b>.segment ..magic_size) + end <b>.bits/8 + #let [expected (`` (char (~~ (static ..null))))] + _ (<>.assert (exception.construct ..wrong_character [expected end]) + (n.= expected end))] + (<>.lift + (\ try.monad map (|>> :abstraction) + (\ utf8.codec decode string))))) + ) + +(def: block_size Size 512) + +(def: owner_id_size ..small_size) + +(def: blank_size Size (text.size ..blank)) +(def: null_size Size (text.size ..null)) +(def: mode_size Size ..small_size) +(def: content_size Size ..big_size) +(def: modification_time_size Size ..big_size) +(def: checksum_size Size ..small_size) +(def: link_flag_size Size 1) +(def: device_size Size ..small_size) + +(def: small_number + (-> Size Size) + (|>> ($_ n.+ ..blank_size ..null_size))) + +(def: big_number + (-> Size Size) + (|>> ($_ n.+ ..blank_size))) + +(def: string + (-> Size Size) + (|>> ($_ n.+ ..null_size))) + +(def: header_size + ($_ n.+ + ## name + (..string ..path_size) + ## mode + (..small_number ..mode_size) + ## uid + (..small_number ..owner_id_size) + ## gid + (..small_number ..owner_id_size) + ## size + (..big_number ..content_size) + ## mtime + (..big_number ..modification_time_size) + ## chksum + (..small_number ..checksum_size) + ## linkflag + ..link_flag_size + ## linkname + (..string ..path_size) + ## magic + (..string ..magic_size) + ## uname + (..string ..name_size) + ## gname + (..string ..name_size) + ## devmajor + (..small_number ..device_size) + ## devminor + (..small_number ..device_size))) + +(abstract: Link_Flag + Char + + (def: link_flag + (-> Link_Flag Char) + (|>> :representation)) + + (def: link_flag_writer + (Writer Link_Flag) + (|>> :representation + format.bits/8)) + + (with_expansions [<options> (as_is [0 old_normal] + [(char "0") normal] + [(char "1") link] + [(char "2") symbolic_link] + [(char "3") character] + [(char "4") block] + [(char "5") directory] + [(char "6") fifo] + [(char "7") contiguous])] + (template [<flag> <name>] + [(def: <name> + Link_Flag + (:abstraction <flag>))] + + <options> + ) + + (exception: #export (invalid_link_flag {value Nat}) + (exception.report + ["Value" (%.nat value)])) + + (def: link_flag_parser + (Parser Link_Flag) + (do <>.monad + [linkflag <b>.bits/8] + (case (.nat linkflag) + (^template [<value> <link_flag>] + [(^ <value>) + (wrap <link_flag>)]) + (<options>) + + _ + (<>.lift + (exception.throw ..invalid_link_flag [(.nat linkflag)])))))) + ) + +(abstract: #export Mode + Nat + + (def: #export mode + (-> Mode Nat) + (|>> :representation)) + + (def: #export (and left right) + (-> Mode Mode Mode) + (:abstraction + (i64.or (:representation left) + (:representation right)))) + + (def: mode_writer + (Writer Mode) + (|>> :representation + ..small + try.assume + ..small_writer)) + + (exception: #export (invalid_mode {value Nat}) + (exception.report + ["Value" (%.nat value)])) + + (with_expansions [<options> (as_is ["0000" none] + + ["0001" execute_by_other] + ["0002" write_by_other] + ["0004" read_by_other] + + ["0010" execute_by_group] + ["0020" write_by_group] + ["0040" read_by_group] + + ["0100" execute_by_owner] + ["0200" write_by_owner] + ["0400" read_by_owner] + + ["1000" save_text] + ["2000" set_group_id_on_execution] + ["4000" set_user_id_on_execution])] + (template [<code> <name>] + [(def: #export <name> + Mode + (:abstraction (number.oct <code>)))] + + <options> + ) + + (def: maximum_mode + Mode + ($_ and + ..none + + ..execute_by_other + ..write_by_other + ..read_by_other + + ..execute_by_group + ..write_by_group + ..read_by_group + + ..execute_by_owner + ..write_by_owner + ..read_by_owner + + ..save_text + ..set_group_id_on_execution + ..set_user_id_on_execution + )) + + (def: mode_parser + (Parser Mode) + (do {! <>.monad} + [value (\ ! map ..from_small ..small_parser)] + (if (n.<= (:representation ..maximum_mode) + value) + (wrap (:abstraction value)) + (<>.lift + (exception.throw ..invalid_mode [value])))))) + ) + +(def: maximum_content_size + Nat + (|> ..octal_size + (list.repeat ..content_size) + (list\fold n.* 1))) + +(abstract: #export Content + [Big Binary] + + (def: #export (content content) + (-> Binary (Try Content)) + (do try.monad + [size (..big (binary.size content))] + (wrap (:abstraction [size content])))) + + (def: from_content + (-> Content [Big Binary]) + (|>> :representation)) + + (def: #export data + (-> Content Binary) + (|>> :representation product.right)) + ) + +(type: #export ID + Small) + +(def: #export no_id + ID + (..coerce_small 0)) + +(type: #export Owner + {#name Name + #id ID}) + +(type: #export Ownership + {#user Owner + #group Owner}) + +(type: #export File + [Path Instant Mode Ownership Content]) + +(type: #export Normal File) +(type: #export Symbolic_Link Path) +(type: #export Directory Path) +(type: #export Contiguous File) + +(type: #export Entry + (#Normal ..Normal) + (#Symbolic_Link ..Symbolic_Link) + (#Directory ..Directory) + (#Contiguous ..Contiguous)) + +(type: Device + Small) + +(def: no_device + Device + (try.assume (..small 0))) + +(type: #export Tar + (Row Entry)) + +(def: (blocks size) + (-> Big Nat) + (n.+ (n./ ..block_size + (..from_big size)) + (case (n.% ..block_size (..from_big size)) + 0 0 + _ 1))) + +(def: rounded_content_size + (-> Big Nat) + (|>> ..blocks + (n.* ..block_size))) + +(type: Header + {#path Path + #mode Mode + #user_id ID + #group_id ID + #size Big + #modification_time Big + #checksum Checksum + #link_flag Link_Flag + #link_name Path + #magic Magic + #user_name Name + #group_name Name + #major_device Device + #minor_device Device}) + +(def: header_writer' + (Writer Header) + ($_ format.and + ..path_writer + ..mode_writer + ..small_writer + ..small_writer + ..big_writer + ..big_writer + ..checksum_writer + ..link_flag_writer + ..path_writer + ..magic_writer + ..name_writer + ..name_writer + ..small_writer + ..small_writer + )) + +(def: (header_writer header) + (Writer Header) + (let [checksum (|> header + (set@ #checksum ..dummy_checksum) + (format.run ..header_writer') + ..checksum_code)] + (|> header + (set@ #checksum checksum) + (format.run ..header_writer') + (format.segment ..block_size)))) + +(def: modification_time + (-> Instant Big) + (|>> instant.relative + (duration.query duration.second) + .nat + ..coerce_big)) + +(def: (file_writer link_flag) + (-> Link_Flag (Writer File)) + (function (_ [path modification_time mode ownership content]) + (let [[size content] (..from_content content) + writer ($_ format.and + ..header_writer + (format.segment (..rounded_content_size size)))] + (writer [{#path path + #mode mode + #user_id (get@ [#user #id] ownership) + #group_id (get@ [#group #id] ownership) + #size size + #modification_time (..modification_time modification_time) + #checksum ..dummy_checksum + #link_flag link_flag + #link_name ..no_path + #magic ..ustar + #user_name (get@ [#user #name] ownership) + #group_name (get@ [#group #name] ownership) + #major_device ..no_device + #minor_device ..no_device} + content])))) + +(def: normal_file_writer + (Writer File) + (..file_writer ..normal)) + +(def: contiguous_file_writer + (Writer File) + (..file_writer ..contiguous)) + +(def: (symbolic_link_writer path) + (Writer Path) + (..header_writer + {#path ..no_path + #mode ..none + #user_id ..no_id + #group_id ..no_id + #size (..coerce_big 0) + #modification_time (..coerce_big 0) + #checksum ..dummy_checksum + #link_flag ..symbolic_link + #link_name path + #magic ..ustar + #user_name ..anonymous + #group_name ..anonymous + #major_device ..no_device + #minor_device ..no_device})) + +(def: (directory_writer path) + (Writer Path) + (..header_writer + {#path path + #mode ..none + #user_id ..no_id + #group_id ..no_id + #size (..coerce_big 0) + #modification_time (..coerce_big 0) + #checksum ..dummy_checksum + #link_flag ..directory + #link_name ..no_path + #magic ..ustar + #user_name ..anonymous + #group_name ..anonymous + #major_device ..no_device + #minor_device ..no_device})) + +(def: entry_writer + (Writer Entry) + (|>> (case> (#Normal value) (..normal_file_writer value) + (#Symbolic_Link value) (..symbolic_link_writer value) + (#Directory value) (..directory_writer value) + (#Contiguous value) (..contiguous_file_writer value)))) + +(def: end_of_archive_size Size (n.* 2 ..block_size)) + +(def: #export writer + (Writer Tar) + (let [end_of_archive (binary.create ..end_of_archive_size)] + (function (_ tar) + (format\compose (row\fold (function (_ next total) + (format\compose total (..entry_writer next))) + format\identity + tar) + (format.segment ..end_of_archive_size end_of_archive))))) + +(exception: #export (wrong_checksum {expected Nat} {actual Nat}) + (exception.report + ["Expected" (%.nat expected)] + ["Actual" (%.nat actual)])) + +(def: header_padding_size + (n.- header_size block_size)) + +## When the checksum gets originally calculated, the assumption is that all the characters in the checksum field +## of the header will be spaces. +## This means that just calculating the checksum of the 512 bytes of the header, when reading them, would yield +## an incorrect result, as the contents of the checksum field would be an actual checksum, instead of just spaces. +## To correct for this, it is necessary to calculate the checksum of just the checksum field, subtract that, and then +## add-in the checksum of the spaces. +(def: (expected_checksum checksum header) + (-> Checksum Binary Nat) + (let [|checksum| (|> checksum + ..from_checksum + (\ utf8.codec encode) + ..checksum)] + (|> (..checksum header) + (n.- |checksum|) + (n.+ ..checksum_checksum)))) + +(def: header_parser + (Parser Header) + (do <>.monad + [binary_header (<>.speculative (<b>.segment block_size)) + path ..path_parser + mode ..mode_parser + user_id ..small_parser + group_id ..small_parser + size ..big_parser + modification_time ..big_parser + [actual checksum_code] ..checksum_parser + _ (let [expected (expected_checksum checksum_code binary_header)] + (<>.lift + (exception.assert ..wrong_checksum [expected actual] + (n.= expected actual)))) + link_flag ..link_flag_parser + link_name ..path_parser + magic ..magic_parser + user_name ..name_parser + group_name ..name_parser + major_device ..small_parser + minor_device ..small_parser + _ (<b>.segment ..header_padding_size)] + (wrap {#path path + #mode mode + #user_id user_id + #group_id group_id + #size size + #modification_time modification_time + #checksum checksum_code + #link_flag link_flag + #link_name link_name + #magic magic + #user_name user_name + #group_name group_name + #major_device major_device + #minor_device minor_device}))) + +(exception: #export (wrong_link_flag {expected Link_Flag} {actual Link_Flag}) + (exception.report + ["Expected" (%.nat (..link_flag expected))] + ["Actual" (%.nat (..link_flag actual))])) + +(def: (file_parser expected) + (-> Link_Flag (Parser File)) + (do <>.monad + [header ..header_parser + _ (<>.assert (exception.construct ..wrong_link_flag [expected (get@ #link_flag header)]) + (is? expected (get@ #link_flag header))) + #let [size (get@ #size header) + rounded_size (..rounded_content_size size)] + content (<b>.segment (..from_big size)) + content (<>.lift (..content content)) + _ (<b>.segment (n.- (..from_big size) rounded_size))] + (wrap [(get@ #path header) + (|> header + (get@ #modification_time) + ..from_big + .int + duration.from_millis + (duration.up (|> duration.second duration.to_millis .nat)) + instant.absolute) + (get@ #mode header) + {#user {#name (get@ #user_name header) + #id (get@ #user_id header)} + #group {#name (get@ #group_name header) + #id (get@ #group_id header)}} + content]))) + +(def: (file_name_parser expected extractor) + (-> Link_Flag (-> Header Path) (Parser Path)) + (do <>.monad + [header ..header_parser + _ (<>.lift + (exception.assert ..wrong_link_flag [expected (get@ #link_flag header)] + (n.= (..link_flag expected) + (..link_flag (get@ #link_flag header)))))] + (wrap (extractor header)))) + +(def: entry_parser + (Parser Entry) + ($_ <>.either + (\ <>.monad map (|>> #..Normal) + (<>.either (..file_parser ..normal) + (..file_parser ..old_normal))) + (\ <>.monad map (|>> #..Symbolic_Link) + (..file_name_parser ..symbolic_link (get@ #link_name))) + (\ <>.monad map (|>> #..Directory) + (..file_name_parser ..directory (get@ #path))) + (\ <>.monad map (|>> #..Contiguous) + (..file_parser ..contiguous)))) + +## It's safe to implement the parser this way because the range of values for Nat is 2^64 +## Whereas the maximum possible value for the checksum of a 512 block is (256 × 512) = 131,072 +(def: end_of_archive_block_parser + (Parser Any) + (do <>.monad + [block (<b>.segment ..block_size)] + (let [actual (..checksum block)] + (<>.lift + (exception.assert ..wrong_checksum [0 actual] + (n.= 0 actual)))))) + +(exception: #export invalid_end_of_archive) + +(def: end_of_archive_parser + (Parser Any) + (do <>.monad + [_ (<>.at_most 2 end_of_archive_block_parser) + done? <b>.end?] + (<>.lift + (exception.assert ..invalid_end_of_archive [] + done?)))) + +(def: #export parser + (Parser Tar) + (|> (<>.some entry_parser) + (\ <>.monad map row.from_list) + (<>.before ..end_of_archive_parser))) diff --git a/stdlib/source/library/lux/data/format/xml.lux b/stdlib/source/library/lux/data/format/xml.lux new file mode 100644 index 000000000..56d394490 --- /dev/null +++ b/stdlib/source/library/lux/data/format/xml.lux @@ -0,0 +1,299 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)] + [equivalence (#+ Equivalence)] + [codec (#+ Codec)]] + [control + [try (#+ Try)] + ["<>" parser ("#\." monad) + ["<.>" text (#+ Parser)]]] + [data + ["." product] + ["." name ("#\." equivalence codec)] + ["." text ("#\." equivalence monoid)] + [collection + ["." list ("#\." functor)] + ["." dictionary (#+ Dictionary)]]] + [math + [number + ["n" nat] + ["." int]]]]]) + +(type: #export Tag + Name) + +(type: #export Attribute + Name) + +(type: #export Attrs + (Dictionary Attribute Text)) + +(def: #export attributes + Attrs + (dictionary.new name.hash)) + +(type: #export #rec XML + (#Text Text) + (#Node Tag Attrs (List XML))) + +(def: namespace_separator + ":") + +(def: xml_standard_escape_char^ + (Parser Text) + ($_ <>.either + (<>.after (<text>.this "<") (<>\wrap "<")) + (<>.after (<text>.this ">") (<>\wrap ">")) + (<>.after (<text>.this "&") (<>\wrap "&")) + (<>.after (<text>.this "'") (<>\wrap "'")) + (<>.after (<text>.this """) (<>\wrap text.double_quote)) + )) + +(def: xml_unicode_escape_char^ + (Parser Text) + (|> (do <>.monad + [hex? (<>.maybe (<text>.this "x")) + code (case hex? + #.None + (<>.codec int.decimal (<text>.many <text>.decimal)) + + (#.Some _) + (<>.codec int.decimal (<text>.many <text>.hexadecimal)))] + (wrap (|> code .nat text.from_code))) + (<>.before (<text>.this ";")) + (<>.after (<text>.this "&#")))) + +(def: xml_escape_char^ + (Parser Text) + (<>.either xml_standard_escape_char^ + xml_unicode_escape_char^)) + +(def: xml_char^ + (Parser Text) + (<>.either (<text>.none_of ($_ text\compose "<>&" text.double_quote)) + xml_escape_char^)) + +(def: xml_identifier + (Parser Text) + (do <>.monad + [head (<>.either (<text>.one_of "_") + <text>.alpha) + tail (<text>.some (<>.either (<text>.one_of "_.-") + <text>.alpha_num))] + (wrap ($_ text\compose head tail)))) + +(def: namespaced_symbol^ + (Parser Name) + (do <>.monad + [first_part xml_identifier + ?second_part (<| <>.maybe (<>.after (<text>.this ..namespace_separator)) xml_identifier)] + (case ?second_part + #.None + (wrap ["" first_part]) + + (#.Some second_part) + (wrap [first_part second_part])))) + +(def: tag^ namespaced_symbol^) +(def: attr_name^ namespaced_symbol^) + +(def: spaced^ + (All [a] (-> (Parser a) (Parser a))) + (let [white_space^ (<>.some <text>.space)] + (|>> (<>.before white_space^) + (<>.after white_space^)))) + +(def: attr_value^ + (Parser Text) + (let [value^ (<text>.some xml_char^)] + (<>.either (<text>.enclosed [text.double_quote text.double_quote] value^) + (<text>.enclosed ["'" "'"] value^)))) + +(def: attrs^ + (Parser Attrs) + (<| (\ <>.monad map (dictionary.from_list name.hash)) + <>.some + (<>.and (..spaced^ attr_name^)) + (<>.after (<text>.this "=")) + (..spaced^ attr_value^))) + +(def: (close_tag^ expected) + (-> Tag (Parser [])) + (do <>.monad + [actual (|> tag^ + ..spaced^ + (<>.after (<text>.this "/")) + (<text>.enclosed ["<" ">"]))] + (<>.assert ($_ text\compose "Close tag does not match open tag." text.new_line + "Expected: " (name\encode expected) text.new_line + " Actual: " (name\encode actual) text.new_line) + (name\= expected actual)))) + +(def: comment^ + (Parser Text) + (|> (<text>.not (<text>.this "--")) + <text>.some + (<text>.enclosed ["<!--" "-->"]) + ..spaced^)) + +(def: xml_header^ + (Parser Attrs) + (|> (..spaced^ attrs^) + (<>.before (<text>.this "?>")) + (<>.after (<text>.this "<?xml")) + ..spaced^)) + +(def: cdata^ + (Parser Text) + (let [end (<text>.this "]]>")] + (|> (<text>.some (<text>.not end)) + (<>.after end) + (<>.after (<text>.this "<![CDATA[")) + ..spaced^))) + +(def: text^ + (Parser XML) + (|> (..spaced^ (<text>.many xml_char^)) + (<>.either cdata^) + (<>\map (|>> #Text)))) + +(def: null^ + (Parser Any) + (<text>.this (text.from_code 0))) + +(def: xml^ + (Parser XML) + (|> (<>.rec + (function (_ node^) + (|> (do <>.monad + [_ (<text>.this "<") + tag (..spaced^ tag^) + attrs (..spaced^ attrs^) + #let [no_children^ ($_ <>.either + (do <>.monad + [_ (<text>.this "/>")] + (wrap (#Node tag attrs (list)))) + (do <>.monad + [_ (<text>.this ">") + _ (<>.some (<>.either <text>.space + ..comment^)) + _ (..close_tag^ tag)] + (wrap (#Node tag attrs (list))))) + with_children^ (do <>.monad + [_ (<text>.this ">") + children (<>.many node^) + _ (..close_tag^ tag)] + (wrap (#Node tag attrs children)))]] + ($_ <>.either + no_children^ + with_children^)) + ..spaced^ + (<>.before (<>.some ..comment^)) + (<>.after (<>.some ..comment^)) + (<>.either ..text^)))) + (<>.before (<>.some ..null^)) + (<>.after (<>.maybe ..xml_header^)))) + +(def: read + (-> Text (Try XML)) + (<text>.run xml^)) + +(def: (sanitize_value input) + (-> Text Text) + (|> input + (text.replace_all "&" "&") + (text.replace_all "<" "<") + (text.replace_all ">" ">") + (text.replace_all "'" "'") + (text.replace_all text.double_quote """))) + +(def: #export (tag [namespace name]) + (-> Tag Text) + (case namespace + "" name + _ ($_ text\compose namespace ..namespace_separator name))) + +(def: #export attribute + (-> Attribute Text) + ..tag) + +(def: (write_attrs attrs) + (-> Attrs Text) + (|> attrs + dictionary.entries + (list\map (function (_ [key value]) + ($_ text\compose (..attribute key) "=" text.double_quote (sanitize_value value) text.double_quote))) + (text.join_with " "))) + +(def: xml_header + Text + (let [quote (: (-> Text Text) + (function (_ value) + ($_ text\compose text.double_quote value text.double_quote)))] + ($_ text\compose + "<?xml" + " version=" (quote "1.0") + " encoding=" (quote "UTF-8") + "?>"))) + +(def: (write input) + (-> XML Text) + ($_ text\compose + ..xml_header text.new_line + (loop [prefix "" + input input] + (case input + (#Text value) + (sanitize_value value) + + (^ (#Node xml_tag xml_attrs (list (#Text value)))) + (let [tag (..tag xml_tag) + attrs (if (dictionary.empty? xml_attrs) + "" + ($_ text\compose " " (..write_attrs xml_attrs)))] + ($_ text\compose + prefix "<" tag attrs ">" + (sanitize_value value) + "</" tag ">")) + + (#Node xml_tag xml_attrs xml_children) + (let [tag (..tag xml_tag) + attrs (if (dictionary.empty? xml_attrs) + "" + ($_ text\compose " " (..write_attrs xml_attrs)))] + (if (list.empty? xml_children) + ($_ text\compose prefix "<" tag attrs "/>") + ($_ text\compose prefix "<" tag attrs ">" + (|> xml_children + (list\map (|>> (recur (text\compose prefix text.tab)) (text\compose text.new_line))) + (text.join_with "")) + text.new_line prefix "</" tag ">"))))) + )) + +(implementation: #export codec + (Codec Text XML) + + (def: encode ..write) + (def: decode ..read)) + +(implementation: #export equivalence + (Equivalence XML) + + (def: (= reference sample) + (case [reference sample] + [(#Text reference/value) (#Text sample/value)] + (text\= reference/value sample/value) + + [(#Node reference/tag reference/attrs reference/children) + (#Node sample/tag sample/attrs sample/children)] + (and (name\= reference/tag sample/tag) + (\ (dictionary.equivalence text.equivalence) = reference/attrs sample/attrs) + (n.= (list.size reference/children) + (list.size sample/children)) + (|> (list.zip/2 reference/children sample/children) + (list.every? (product.uncurry =)))) + + _ + false))) diff --git a/stdlib/source/library/lux/data/identity.lux b/stdlib/source/library/lux/data/identity.lux new file mode 100644 index 000000000..c0a39ab5e --- /dev/null +++ b/stdlib/source/library/lux/data/identity.lux @@ -0,0 +1,38 @@ +(.module: + [library + [lux #* + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad)] + [comonad (#+ CoMonad)]] + [control + ["." function]]]]) + +(type: #export (Identity a) + a) + +(implementation: #export functor + (Functor Identity) + + (def: map function.identity)) + +(implementation: #export apply + (Apply Identity) + + (def: &functor ..functor) + (def: (apply ff fa) (ff fa))) + +(implementation: #export monad + (Monad Identity) + + (def: &functor ..functor) + (def: wrap function.identity) + (def: join function.identity)) + +(implementation: #export comonad + (CoMonad Identity) + + (def: &functor ..functor) + (def: unwrap function.identity) + (def: split function.identity)) diff --git a/stdlib/source/library/lux/data/lazy.lux b/stdlib/source/library/lux/data/lazy.lux new file mode 100644 index 000000000..c9a6ae18c --- /dev/null +++ b/stdlib/source/library/lux/data/lazy.lux @@ -0,0 +1,68 @@ +(.module: + [library + [lux #* + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)] + [equivalence (#+ Equivalence)]] + [control + ["." io] + [parser + ["s" code]] + [concurrency + ["." atom]]] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)]] + [type + abstract]]]) + +(abstract: #export (Lazy a) + (-> [] a) + + (def: (freeze' generator) + (All [a] (-> (-> [] a) (Lazy a))) + (let [cache (atom.atom #.None)] + (:abstraction (function (_ _) + (case (io.run (atom.read cache)) + (#.Some value) + value + + _ + (let [value (generator [])] + (exec (io.run (atom.compare_and_swap _ (#.Some value) cache)) + value))))))) + + (def: #export (thaw l_value) + (All [a] (-> (Lazy a) a)) + ((:representation l_value) []))) + +(syntax: #export (freeze expr) + (with_gensyms [g!_] + (wrap (list (` ((~! freeze') (function ((~ g!_) (~ g!_)) (~ expr)))))))) + +(implementation: #export (equivalence (^open "_\.")) + (All [a] (-> (Equivalence a) (Equivalence (Lazy a)))) + + (def: (= left right) + (_\= (..thaw left) (..thaw right)))) + +(implementation: #export functor + (Functor Lazy) + + (def: (map f fa) + (freeze (f (thaw fa))))) + +(implementation: #export apply + (Apply Lazy) + + (def: &functor ..functor) + (def: (apply ff fa) + (freeze ((thaw ff) (thaw fa))))) + +(implementation: #export monad + (Monad Lazy) + + (def: &functor ..functor) + (def: wrap (|>> freeze)) + (def: join thaw)) diff --git a/stdlib/source/library/lux/data/maybe.lux b/stdlib/source/library/lux/data/maybe.lux new file mode 100644 index 000000000..d7f010f13 --- /dev/null +++ b/stdlib/source/library/lux/data/maybe.lux @@ -0,0 +1,151 @@ +(.module: + [library + [lux #* + [abstract + [monoid (#+ Monoid)] + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + [apply (#+ Apply)] + ["." functor (#+ Functor)] + ["." monad (#+ Monad do)]] + [meta + ["." location]]]]) + +## (type: (Maybe a) +## #.None +## (#.Some a)) + +(implementation: #export monoid + (All [a] (Monoid (Maybe a))) + + (def: identity #.None) + + (def: (compose mx my) + (case mx + #.None + my + + (#.Some x) + (#.Some x)))) + +(implementation: #export functor + (Functor Maybe) + + (def: (map f ma) + (case ma + #.None #.None + (#.Some a) (#.Some (f a))))) + +(implementation: #export apply + (Apply Maybe) + + (def: &functor ..functor) + + (def: (apply ff fa) + (case [ff fa] + [(#.Some f) (#.Some a)] + (#.Some (f a)) + + _ + #.None))) + +(implementation: #export monad + (Monad Maybe) + + (def: &functor ..functor) + + (def: (wrap x) + (#.Some x)) + + (def: (join mma) + (case mma + #.None + #.None + + (#.Some mx) + mx))) + +(implementation: #export (equivalence super) + (All [a] (-> (Equivalence a) (Equivalence (Maybe a)))) + + (def: (= mx my) + (case [mx my] + [#.None #.None] + #1 + + [(#.Some x) (#.Some y)] + (\ super = x y) + + _ + #0))) + +(implementation: #export (hash super) + (All [a] (-> (Hash a) (Hash (Maybe a)))) + + (def: &equivalence + (..equivalence (\ super &equivalence))) + + (def: (hash value) + (case value + #.None + 0 + + (#.Some value) + (\ super hash value)))) + +(implementation: #export (with monad) + (All [M] (-> (Monad M) (Monad (All [a] (M (Maybe a)))))) + + (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor)) + + (def: wrap (|>> (\ ..monad wrap) (\ monad wrap))) + + (def: (join MmMma) + (do monad + [mMma MmMma] + (case mMma + #.None + (wrap #.None) + + (#.Some Mma) + Mma)))) + +(def: #export (lift monad) + (All [M a] (-> (Monad M) (-> (M a) (M (Maybe a))))) + (\ monad map (\ ..monad wrap))) + +(macro: #export (default tokens state) + {#.doc (doc "Allows you to provide a default value that will be used" + "if a (Maybe x) value turns out to be #.None." + "Note: the expression for the default value will not be computed if the base computation succeeds." + (default +20 (#.Some +10)) + "=>" + +10 + (default +20 #.None) + "=>" + +20)} + (case tokens + (^ (list else maybe)) + (let [g!temp (: Code [location.dummy (#.Identifier ["" ""])])] + (#.Right [state (list (` (case (~ maybe) + (#.Some (~ g!temp)) + (~ g!temp) + + #.None + (~ else))))])) + + _ + (#.Left "Wrong syntax for default"))) + +(def: #export assume + (All [a] (-> (Maybe a) a)) + (|>> (..default (undefined)))) + +(def: #export (to-list value) + (All [a] (-> (Maybe a) (List a))) + (case value + #.None + #.Nil + + (#.Some value) + (#.Cons value #.Nil))) diff --git a/stdlib/source/library/lux/data/name.lux b/stdlib/source/library/lux/data/name.lux new file mode 100644 index 000000000..6a89a1aa6 --- /dev/null +++ b/stdlib/source/library/lux/data/name.lux @@ -0,0 +1,64 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + [order (#+ Order)] + [codec (#+ Codec)]] + [data + ["." text ("#\." equivalence monoid)] + ["." product]]]]) + +## (type: Name +## [Text Text]) + +(template [<name> <side>] + [(def: #export (<name> [module short]) + (-> Name Text) + <side>)] + + [module module] + [short short] + ) + +(def: #export hash + (Hash Name) + (product.hash text.hash text.hash)) + +(def: #export equivalence + (Equivalence Name) + (\ ..hash &equivalence)) + +(implementation: #export order + (Order Name) + + (def: &equivalence ..equivalence) + (def: (< [moduleP shortP] [moduleS shortS]) + (if (text\= moduleP moduleS) + (\ text.order < shortP shortS) + (\ text.order < moduleP moduleS)))) + +(def: separator + ".") + +(implementation: #export codec + (Codec Text Name) + + (def: (encode [module short]) + (case module + "" short + _ ($_ text\compose module ..separator short))) + + (def: (decode input) + (if (text\= "" input) + (#.Left (text\compose "Invalid format for Name: " input)) + (case (text.split_all_with ..separator input) + (^ (list short)) + (#.Right ["" short]) + + (^ (list module short)) + (#.Right [module short]) + + _ + (#.Left (text\compose "Invalid format for Name: " input)))))) diff --git a/stdlib/source/library/lux/data/product.lux b/stdlib/source/library/lux/data/product.lux new file mode 100644 index 000000000..6cf05ac83 --- /dev/null +++ b/stdlib/source/library/lux/data/product.lux @@ -0,0 +1,69 @@ +(.module: + {#.doc "Functionality for working with tuples (particularly 2-tuples)."} + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]]]]) + +(template [<name> <type> <output>] + [(def: #export (<name> xy) + (All [a b] (-> (& a b) <type>)) + (let [[x y] xy] + <output>))] + + [left a x] + [right b y] + ) + +(def: #export (curry f) + (All [a b c] + (-> (-> (& a b) c) + (-> a b c))) + (function (_ x y) + (f [x y]))) + +(def: #export (uncurry f) + (All [a b c] + (-> (-> a b c) + (-> (& a b) c))) + (function (_ xy) + (let [[x y] xy] + (f x y)))) + +(def: #export (swap xy) + (All [a b] (-> (& a b) (& b a))) + (let [[x y] xy] + [y x])) + +(def: #export (apply f g) + (All [a b c d] + (-> (-> a c) (-> b d) + (-> (& a b) (& c d)))) + (function (_ [x y]) + [(f x) (g y)])) + +(def: #export (fork f g) + (All [a l r] + (-> (-> a l) (-> a r) + (-> a (& l r)))) + (function (_ x) + [(f x) (g x)])) + +(implementation: #export (equivalence left right) + (All [l r] (-> (Equivalence l) (Equivalence r) (Equivalence [l r]))) + + (def: (= [rl rr] [sl sr]) + (and (\ left = rl sl) + (\ right = rr sr)))) + +(def: #export (hash left right) + (All [l r] (-> (Hash l) (Hash r) (Hash (& l r)))) + (implementation + (def: &equivalence + (..equivalence (\ left &equivalence) + (\ right &equivalence))) + (def: (hash [leftV rightV]) + ("lux i64 +" + (\ left hash leftV) + (\ right hash rightV))))) diff --git a/stdlib/source/library/lux/data/store.lux b/stdlib/source/library/lux/data/store.lux new file mode 100644 index 000000000..3a6d73386 --- /dev/null +++ b/stdlib/source/library/lux/data/store.lux @@ -0,0 +1,50 @@ +(.module: + [library + [lux #* + [abstract + [functor (#+ Functor)] + comonad] + [type + implicit]]]) + +(type: #export (Store s a) + {#cursor s + #peek (-> s a)}) + +(def: (extend f wa) + (All [s a b] (-> (-> (Store s a) b) (Store s a) (Store s b))) + {#cursor (get@ #cursor wa) + #peek (function (_ s) (f (set@ #cursor s wa)))}) + +(implementation: #export functor + (All [s] (Functor (Store s))) + + (def: (map f fa) + (extend (function (_ store) + (f (\ store peek (\ store cursor)))) + fa))) + +(implementation: #export comonad + (All [s] (CoMonad (Store s))) + + (def: &functor ..functor) + + (def: (unwrap wa) (\\ peek (\\ cursor))) + + (def: split (extend id))) + +(def: #export (peeks trans store) + (All [s a] (-> (-> s s) (Store s a) a)) + (|> (\\ cursor) trans (\\ peek))) + +(def: #export (seek cursor store) + (All [s a] (-> s (Store s a) (Store s a))) + (\ (\\ split store) peek cursor)) + +(def: #export (seeks change store) + (All [s a] (-> (-> s s) (Store s a) (Store s a))) + (|> store (\\ split) (peeks change))) + +(def: #export (experiment Functor<f> change store) + (All [f s a] (-> (Functor f) (-> s (f s)) (Store s a) (f a))) + (\ Functor<f> map (\\ peek) (change (\\ cursor)))) diff --git a/stdlib/source/library/lux/data/sum.lux b/stdlib/source/library/lux/data/sum.lux new file mode 100644 index 000000000..7a439fc54 --- /dev/null +++ b/stdlib/source/library/lux/data/sum.lux @@ -0,0 +1,90 @@ +(.module: + {#.doc "Functionality for working with variants (particularly 2-variants)."} + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]]]]) + +(template [<name> <type> <right?>] + [(def: #export (<name> value) + (All [a b] (-> <type> (| a b))) + (0 <right?> value))] + + [left a #0] + [right b #1]) + +(def: #export (either fl fr) + (All [a b c] + (-> (-> a c) (-> b c) + (-> (| a b) c))) + (function (_ input) + (case input + (0 #0 l) (fl l) + (0 #1 r) (fr r)))) + +(def: #export (apply fl fr) + (All [l l' r r'] + (-> (-> l l') (-> r r') + (-> (| l r) (| l' r')))) + (function (_ input) + (case input + (0 #0 l) (0 #0 (fl l)) + (0 #1 r) (0 #1 (fr r))))) + +(template [<name> <side> <right?>] + [(def: #export (<name> es) + (All [a b] (-> (List (| a b)) (List <side>))) + (case es + #.Nil + #.Nil + + (#.Cons (0 <right?> x) es') + (#.Cons [x (<name> es')]) + + (#.Cons _ es') + (<name> es')))] + + [lefts a #0] + [rights b #1] + ) + +(def: #export (partition xs) + (All [a b] (-> (List (| a b)) [(List a) (List b)])) + (case xs + #.Nil + [#.Nil #.Nil] + + (#.Cons x xs') + (let [[lefts rights] (partition xs')] + (case x + (0 #0 x') [(#.Cons x' lefts) rights] + (0 #1 x') [lefts (#.Cons x' rights)])))) + +(def: #export (equivalence left right) + (All [l r] (-> (Equivalence l) (Equivalence r) (Equivalence (| l r)))) + (implementation + (def: (= reference sample) + (case [reference sample] + [(#.Left reference) (#.Left sample)] + (\ left = reference sample) + + [(#.Right reference) (#.Right sample)] + (\ right = reference sample) + + _ + false)))) + +(def: #export (hash left right) + (All [l r] (-> (Hash l) (Hash r) (Hash (| l r)))) + (implementation + (def: &equivalence + (..equivalence (\ left &equivalence) + (\ right &equivalence))) + (def: (hash value) + (case value + (#.Left value) + (\ left hash value) + + (#.Right value) + (\ right hash value))))) diff --git a/stdlib/source/library/lux/data/text.lux b/stdlib/source/library/lux/data/text.lux new file mode 100644 index 000000000..6acc3233c --- /dev/null +++ b/stdlib/source/library/lux/data/text.lux @@ -0,0 +1,380 @@ +(.module: + [library + [lux #* + ["@" target] + [abstract + [hash (#+ Hash)] + [monoid (#+ Monoid)] + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [monad (#+ Monad do)] + [codec (#+ Codec)]] + [data + ["." maybe] + [collection + ["." list ("#\." fold)]]] + [math + [number + ["n" nat] + ["." i64]]]]]) + +(type: #export Char + Nat) + +## TODO: Instead of ints, chars should be produced fron nats. +## (The JVM specifies chars as 16-bit unsigned integers) +(def: #export from_code + (-> Char Text) + (|>> .int "lux i64 char")) + +(template [<code> <short> <long>] + [(def: #export <long> (from_code <code>)) + (def: #export <short> <long>)] + + [00 \0 null] + [07 \a alarm] + [08 \b back_space] + [09 \t tab] + [10 \n new_line] + [11 \v vertical_tab] + [12 \f form_feed] + [13 \r carriage_return] + [34 \'' double_quote] + ) + +(def: #export line_feed ..new_line) + +(def: #export size + (-> Text Nat) + (|>> "lux text size")) + +(def: #export (nth idx input) + (-> Nat Text (Maybe Char)) + (if (n.< ("lux text size" input) idx) + (#.Some ("lux text char" idx input)) + #.None)) + +(def: #export (index_of' pattern from input) + (-> Text Nat Text (Maybe Nat)) + ("lux text index" from pattern input)) + +(def: #export (index_of pattern input) + (-> Text Text (Maybe Nat)) + ("lux text index" 0 pattern input)) + +(def: (last_index_of'' part since text) + (-> Text Nat Text (Maybe Nat)) + (case ("lux text index" (inc since) part text) + #.None + (#.Some since) + + (#.Some since') + (last_index_of'' part since' text))) + +(def: #export (last_index_of' part from text) + (-> Text Nat Text (Maybe Nat)) + (case ("lux text index" from part text) + (#.Some since) + (last_index_of'' part since text) + + #.None + #.None)) + +(def: #export (last_index_of part text) + (-> Text Text (Maybe Nat)) + (case ("lux text index" 0 part text) + (#.Some since) + (last_index_of'' part since text) + + #.None + #.None)) + +(def: #export (starts_with? prefix x) + (-> Text Text Bit) + (case (index_of prefix x) + (#.Some 0) + true + + _ + false)) + +(def: #export (ends_with? postfix x) + (-> Text Text Bit) + (case (last_index_of postfix x) + (#.Some n) + (n.= (size x) + (n.+ (size postfix) n)) + + _ + false)) + +(def: #export (encloses? boundary value) + (-> Text Text Bit) + (and (starts_with? boundary value) + (ends_with? boundary value))) + +(def: #export (contains? sub text) + (-> Text Text Bit) + (case ("lux text index" 0 sub text) + (#.Some _) + true + + _ + false)) + +(def: #export (prefix param subject) + (-> Text Text Text) + ("lux text concat" param subject)) + +(def: #export (suffix param subject) + (-> Text Text Text) + ("lux text concat" subject param)) + +(def: #export (enclose [left right] content) + {#.doc "Surrounds the given content text with left and right side additions."} + (-> [Text Text] Text Text) + ($_ "lux text concat" left content right)) + +(def: #export (enclose' boundary content) + {#.doc "Surrounds the given content text with the same boundary text."} + (-> Text Text Text) + (enclose [boundary boundary] content)) + +(def: #export format + (-> Text Text) + (..enclose' ..double_quote)) + +(def: #export (clip offset characters input) + (-> Nat Nat Text (Maybe Text)) + (if (|> characters (n.+ offset) (n.<= ("lux text size" input))) + (#.Some ("lux text clip" offset characters input)) + #.None)) + +(def: #export (clip' offset input) + (-> Nat Text (Maybe Text)) + (let [size ("lux text size" input)] + (if (n.<= size offset) + (#.Some ("lux text clip" offset (n.- offset size) input)) + #.None))) + +(def: #export (split at x) + (-> Nat Text (Maybe [Text Text])) + (case [(..clip 0 at x) (..clip' at x)] + [(#.Some pre) (#.Some post)] + (#.Some [pre post]) + + _ + #.None)) + +(def: #export (split_with token sample) + (-> Text Text (Maybe [Text Text])) + (do maybe.monad + [index (index_of token sample) + [pre post'] (split index sample) + [_ post] (split (size token) post')] + (wrap [pre post]))) + +(def: #export (split_all_with token sample) + (-> Text Text (List Text)) + (loop [input sample + output (: (List Text) (list))] + (case (..split_with token input) + (#.Some [pre post]) + (|> output + (#.Cons pre) + (recur post)) + + #.None + (|> output + (#.Cons input) + list.reverse)))) + +(def: #export (replace_once pattern replacement template) + (-> Text Text Text Text) + (<| (maybe.default template) + (do maybe.monad + [[pre post] (..split_with pattern template)] + (wrap ($_ "lux text concat" pre replacement post))))) + +(def: #export (replace_all pattern replacement template) + (-> Text Text Text Text) + (for {@.old + (:as Text + ("jvm invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence" + (:as (primitive "java.lang.String") template) + (:as (primitive "java.lang.CharSequence") pattern) + (:as (primitive "java.lang.CharSequence") replacement))) + @.jvm + (:as Text + ("jvm member invoke virtual" [] "java.lang.String" "replace" [] + (:as (primitive "java.lang.String") template) + ["Ljava/lang/CharSequence;" (:as (primitive "java.lang.CharSequence") pattern)] + ["Ljava/lang/CharSequence;" (:as (primitive "java.lang.CharSequence") replacement)])) + ## TODO: Comment/turn-off when generating a JS compiler using a JVM-based compiler because Nashorn's implementation of "replaceAll" is incorrect. + @.js + (:as Text + ("js object do" "replaceAll" template [pattern replacement])) + @.python + (:as Text + ("python object do" "replace" template pattern replacement)) + ## TODO @.lua + @.ruby + (:as Text + ("ruby object do" "gsub" template pattern replacement)) + @.php + (:as Text + ("php apply" (:assume ("php constant" "str_replace")) + pattern replacement template)) + ## TODO @.scheme + ## TODO @.common_lisp + ## TODO @.r + } + ## Inefficient default + (loop [left "" + right template] + (case (..split_with pattern right) + (#.Some [pre post]) + (recur ($_ "lux text concat" left pre replacement) post) + + #.None + ("lux text concat" left right))))) + +(implementation: #export equivalence + (Equivalence Text) + + (def: (= reference sample) + ("lux text =" reference sample))) + +(implementation: #export order + (Order Text) + + (def: &equivalence ..equivalence) + + (def: (< reference sample) + ("lux text <" reference sample))) + +(implementation: #export monoid + (Monoid Text) + + (def: identity "") + + (def: (compose left right) + ("lux text concat" left right))) + +(implementation: #export hash + (Hash Text) + + (def: &equivalence ..equivalence) + + (def: (hash input) + (for {@.old + (|> input + (: (primitive "java.lang.String")) + "jvm invokevirtual:java.lang.String:hashCode:" + "jvm convert int-to-long" + (:as Nat)) + + @.jvm + (|> input + (:as (primitive "java.lang.String")) + ("jvm member invoke virtual" [] "java.lang.String" "hashCode" []) + "jvm conversion int-to-long" + "jvm object cast" + (: (primitive "java.lang.Long")) + (:as Nat))} + ## Platform-independent default. + (let [length ("lux text size" input)] + (loop [idx 0 + hash 0] + (if (n.< length idx) + (recur (inc idx) + (|> hash + (i64.left_shift 5) + (n.- hash) + (n.+ ("lux text char" idx input)))) + hash)))))) + +(def: #export concat + (-> (List Text) Text) + (let [(^open ".") ..monoid] + (|>> list.reverse (list\fold compose identity)))) + +(def: #export (join_with sep texts) + (-> Text (List Text) Text) + (|> texts (list.interpose sep) concat)) + +(def: #export (empty? text) + (-> Text Bit) + (case text + "" true + _ false)) + +(def: #export space + Text + " ") + +(def: #export (space? char) + {#.doc "Checks whether the character is white-space."} + (-> Char Bit) + (with_expansions [<options> (template [<char>] + [(^ (char (~~ (static <char>))))] + + [..tab] + [..vertical_tab] + [..space] + [..new_line] + [..carriage_return] + [..form_feed] + )] + (`` (case char + (^or <options>) + true + + _ + false)))) + +(def: #export (lower_case value) + (-> Text Text) + (for {@.old + (:as Text + ("jvm invokevirtual:java.lang.String:toLowerCase:" + (:as (primitive "java.lang.String") value))) + @.jvm + (:as Text + ("jvm member invoke virtual" [] "java.lang.String" "toLowerCase" [] + (:as (primitive "java.lang.String") value))) + @.js + (:as Text + ("js object do" "toLowerCase" value [])) + @.python + (:as Text + ("python object do" "lower" value)) + @.lua + (:as Text + ("lua apply" ("lua constant" "string.lower") value)) + @.ruby + (:as Text + ("ruby object do" "downcase" value))})) + +(def: #export (upper_case value) + (-> Text Text) + (for {@.old + (:as Text + ("jvm invokevirtual:java.lang.String:toUpperCase:" + (:as (primitive "java.lang.String") value))) + @.jvm + (:as Text + ("jvm member invoke virtual" [] "java.lang.String" "toUpperCase" [] + (:as (primitive "java.lang.String") value))) + @.js + (:as Text + ("js object do" "toUpperCase" value [])) + @.python + (:as Text + ("python object do" "upper" value)) + @.lua + (:as Text + ("lua apply" ("lua constant" "string.upper") value)) + @.ruby + (:as Text + ("ruby object do" "upcase" value))})) diff --git a/stdlib/source/library/lux/data/text/buffer.lux b/stdlib/source/library/lux/data/text/buffer.lux new file mode 100644 index 000000000..5766d25ef --- /dev/null +++ b/stdlib/source/library/lux/data/text/buffer.lux @@ -0,0 +1,115 @@ +(.module: + [library + [lux #* + [ffi (#+ import:)] + ["@" target] + [control + ["." function]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." array] + ["." row (#+ Row) ("#\." fold)]]] + [math + [number + ["n" nat]]] + [type + abstract]]] + ["." //]) + +(with_expansions [<jvm> (as_is (import: java/lang/CharSequence) + + (import: java/lang/Appendable + ["#::." + (append [java/lang/CharSequence] java/lang/Appendable)]) + + (import: java/lang/String + ["#::." + (new [int]) + (toString [] java/lang/String)]) + + (import: java/lang/StringBuilder + ["#::." + (new [int]) + (toString [] java/lang/String)]))] + (`` (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>) + @.lua (as_is (import: (table/concat [(array.Array Text) Text] Text)) + ##https://www.lua.org/manual/5.3/manual.html#pdf-table.concat + (import: (table/insert [(array.Array Text) Text] #? Nothing)) + ## https://www.lua.org/manual/5.3/manual.html#pdf-table.insert + )} + (as_is)))) + +(`` (abstract: #export Buffer + (for {@.old [Nat (-> java/lang/StringBuilder java/lang/StringBuilder)] + @.jvm [Nat (-> java/lang/StringBuilder java/lang/StringBuilder)] + @.lua [Nat (-> (array.Array Text) (array.Array Text))]} + ## default + (Row Text)) + + {#.doc "Immutable text buffer for efficient text concatenation."} + + (def: #export empty + Buffer + (:abstraction (with_expansions [<jvm> [0 function.identity]] + (for {@.old <jvm> + @.jvm <jvm> + @.lua [0 function.identity]} + ## default + row.empty)))) + + (def: #export (append chunk buffer) + (-> Text Buffer Buffer) + (with_expansions [<jvm> (let [[capacity transform] (:representation buffer) + append! (: (-> Text java/lang/StringBuilder java/lang/StringBuilder) + (function (_ chunk builder) + (exec + (java/lang/Appendable::append (:as java/lang/CharSequence chunk) + builder) + builder)))] + (:abstraction [(n.+ (//.size chunk) capacity) + (|>> transform (append! chunk))]))] + (for {@.old <jvm> + @.jvm <jvm> + @.lua (let [[capacity transform] (:representation buffer) + append! (: (-> Text (array.Array Text) (array.Array Text)) + (function (_ chunk array) + (exec + (table/insert [array chunk]) + array)))] + (:abstraction [(n.+ (//.size chunk) capacity) + (|>> transform (append! chunk))]))} + ## default + (|> buffer :representation (row.add chunk) :abstraction)))) + + (def: #export size + (-> Buffer Nat) + (with_expansions [<jvm> (|>> :representation product.left)] + (for {@.old <jvm> + @.jvm <jvm> + @.lua <jvm>} + ## default + (|>> :representation + (row\fold (function (_ chunk total) + (n.+ (//.size chunk) total)) + 0))))) + + (def: #export (text buffer) + (-> Buffer Text) + (with_expansions [<jvm> (let [[capacity transform] (:representation buffer)] + (|> (java/lang/StringBuilder::new (.int capacity)) + transform + java/lang/StringBuilder::toString))] + (for {@.old <jvm> + @.jvm <jvm> + @.lua (let [[capacity transform] (:representation buffer)] + (table/concat [(transform (array.new 0)) ""]))} + ## default + (row\fold (function (_ chunk total) + (format total chunk)) + "" + (:representation buffer))))) + )) diff --git a/stdlib/source/library/lux/data/text/encoding.lux b/stdlib/source/library/lux/data/text/encoding.lux new file mode 100644 index 000000000..3ecb5b4e0 --- /dev/null +++ b/stdlib/source/library/lux/data/text/encoding.lux @@ -0,0 +1,163 @@ +(.module: + [library + [lux #* + [type + abstract]]]) + +## https://docs.oracle.com/javase/8/docs/technotes/guides/intl/encoding.doc.html + +(abstract: #export Encoding + Text + + (template [<name> <encoding>] + [(def: #export <name> Encoding (:abstraction <encoding>))] + + [ascii "ASCII"] + + [ibm_37 "IBM037"] + [ibm_273 "IBM273"] + [ibm_277 "IBM277"] + [ibm_278 "IBM278"] + [ibm_280 "IBM280"] + [ibm_284 "IBM284"] + [ibm_285 "IBM285"] + [ibm_290 "IBM290"] + [ibm_297 "IBM297"] + [ibm_300 "IBM300"] + [ibm_420 "IBM420"] + [ibm_424 "IBM424"] + [ibm_437 "IBM437"] + [ibm_500 "IBM500"] + [ibm_737 "IBM737"] + [ibm_775 "IBM775"] + [ibm_833 "IBM833"] + [ibm_834 "IBM834"] + [ibm_838 "IBM-Thai"] + [ibm_850 "IBM850"] + [ibm_852 "IBM852"] + [ibm_855 "IBM855"] + [ibm_856 "IBM856"] + [ibm_857 "IBM857"] + [ibm_858 "IBM00858"] + [ibm_860 "IBM860"] + [ibm_861 "IBM861"] + [ibm_862 "IBM862"] + [ibm_863 "IBM863"] + [ibm_864 "IBM864"] + [ibm_865 "IBM865"] + [ibm_866 "IBM866"] + [ibm_868 "IBM868"] + [ibm_869 "IBM869"] + [ibm_870 "IBM870"] + [ibm_871 "IBM871"] + [ibm_874 "IBM874"] + [ibm_875 "IBM875"] + [ibm_918 "IBM918"] + [ibm_921 "IBM921"] + [ibm_922 "IBM922"] + [ibm_930 "IBM930"] + [ibm_933 "IBM933"] + [ibm_935 "IBM935"] + [ibm_937 "IBM937"] + [ibm_939 "IBM939"] + [ibm_942 "IBM942"] + [ibm_942c "IBM942C"] + [ibm_943 "IBM943"] + [ibm_943c "IBM943C"] + [ibm_948 "IBM948"] + [ibm_949 "IBM949"] + [ibm_949c "IBM949C"] + [ibm_950 "IBM950"] + [ibm_964 "IBM964"] + [ibm_970 "IBM970"] + [ibm_1006 "IBM1006"] + [ibm_1025 "IBM1025"] + [ibm_1026 "IBM1026"] + [ibm_1046 "IBM1046"] + [ibm_1047 "IBM1047"] + [ibm_1097 "IBM1097"] + [ibm_1098 "IBM1098"] + [ibm_1112 "IBM1112"] + [ibm_1122 "IBM1122"] + [ibm_1123 "IBM1123"] + [ibm_1124 "IBM1124"] + [ibm_1140 "IBM01140"] + [ibm_1141 "IBM01141"] + [ibm_1142 "IBM01142"] + [ibm_1143 "IBM01143"] + [ibm_1144 "IBM01144"] + [ibm_1145 "IBM01145"] + [ibm_1146 "IBM01146"] + [ibm_1147 "IBM01147"] + [ibm_1148 "IBM01148"] + [ibm_1149 "IBM01149"] + [ibm_1166 "IBM1166"] + [ibm_1364 "IBM1364"] + [ibm_1381 "IBM1381"] + [ibm_1383 "IBM1383"] + [ibm_33722 "IBM33722"] + + [iso_2022_cn "ISO-2022-CN"] + [iso2022_cn_cns "ISO2022-CN-CNS"] + [iso2022_cn_gb "ISO2022-CN-GB"] + [iso_2022_jp "ISO-2022-JP"] + [iso_2022_jp_2 "ISO-2022-JP-2"] + [iso_2022_kr "ISO-2022-KR"] + [iso_8859_1 "ISO-8859-1"] + [iso_8859_2 "ISO-8859-2"] + [iso_8859_3 "ISO-8859-3"] + [iso_8859_4 "ISO-8859-4"] + [iso_8859_5 "ISO-8859-5"] + [iso_8859_6 "ISO-8859-6"] + [iso_8859_7 "ISO-8859-7"] + [iso_8859_8 "ISO-8859-8"] + [iso_8859_9 "ISO-8859-9"] + [iso_8859_11 "iso-8859-11"] + [iso_8859_13 "ISO-8859-13"] + [iso_8859_15 "ISO-8859-15"] + + [mac_arabic "MacArabic"] + [mac_central_europe "MacCentralEurope"] + [mac_croatian "MacCroatian"] + [mac_cyrillic "MacCyrillic"] + [mac_dingbat "MacDingbat"] + [mac_greek "MacGreek"] + [mac_hebrew "MacHebrew"] + [mac_iceland "MacIceland"] + [mac_roman "MacRoman"] + [mac_romania "MacRomania"] + [mac_symbol "MacSymbol"] + [mac_thai "MacThai"] + [mac_turkish "MacTurkish"] + [mac_ukraine "MacUkraine"] + + [utf_8 "UTF-8"] + [utf_16 "UTF-16"] + [utf_32 "UTF-32"] + + [windows_31j "windows-31j"] + [windows_874 "windows-874"] + [windows_949 "windows-949"] + [windows_950 "windows-950"] + [windows_1250 "windows-1250"] + [windows_1252 "windows-1252"] + [windows_1251 "windows-1251"] + [windows_1253 "windows-1253"] + [windows_1254 "windows-1254"] + [windows_1255 "windows-1255"] + [windows_1256 "windows-1256"] + [windows_1257 "windows-1257"] + [windows_1258 "windows-1258"] + [windows_iso2022jp "windows-iso2022jp"] + [windows_50220 "windows-50220"] + [windows_50221 "windows-50221"] + + [cesu_8 "CESU-8"] + [koi8_r "KOI8-R"] + [koi8_u "KOI8-U"] + ) + + (def: #export name + (-> Encoding Text) + (|>> :representation)) + ) diff --git a/stdlib/source/library/lux/data/text/encoding/utf8.lux b/stdlib/source/library/lux/data/text/encoding/utf8.lux new file mode 100644 index 000000000..b24c88837 --- /dev/null +++ b/stdlib/source/library/lux/data/text/encoding/utf8.lux @@ -0,0 +1,164 @@ +(.module: + [library + [lux #* + ["@" target] + ["." ffi] + [abstract + [codec (#+ Codec)]] + [control + ["." try (#+ Try)]] + [data + ["." binary (#+ Binary)]]]] + ["." //]) + +(with_expansions [<jvm> (as_is (ffi.import: java/lang/String + ["#::." + (new [[byte] java/lang/String]) + (getBytes [java/lang/String] [byte])]))] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>) + + @.js + (as_is (ffi.import: Uint8Array) + + ## On Node + (ffi.import: Buffer + ["#::." + (#static from #as from|encode [ffi.String ffi.String] Buffer) + (#static from #as from|decode [Uint8Array] Buffer) + (toString [ffi.String] ffi.String)]) + + ## On the browser + (ffi.import: TextEncoder + ["#::." + (new [ffi.String]) + (encode [ffi.String] Uint8Array)]) + + (ffi.import: TextDecoder + ["#::." + (new [ffi.String]) + (decode [Uint8Array] ffi.String)])) + + @.ruby + (as_is (ffi.import: String #as RubyString + ["#::." + (encode [Text] RubyString) + (force_encoding [Text] Text) + (bytes [] Binary)]) + + (ffi.import: Array #as RubyArray + ["#::." + (pack [Text] RubyString)])) + + @.php + (as_is (ffi.import: Almost_Binary) + (ffi.import: (unpack [ffi.String ffi.String] Almost_Binary)) + (ffi.import: (array_values [Almost_Binary] Binary)) + (def: php_byte_array_format "C*")) + + @.scheme + ## https://srfi.schemers.org/srfi-140/srfi-140.html + (as_is (ffi.import: (string->utf8 [Text] Binary)) + (ffi.import: (utf8->string [Binary] Text)))} + (as_is))) + +(def: (encode value) + (-> Text Binary) + (for {@.old + (java/lang/String::getBytes (//.name //.utf_8) + ## TODO: Remove coercion below. + ## The coercion below may seem + ## gratuitous, but removing it + ## causes a grave compilation problem. + (:as java/lang/String value)) + + @.jvm + (java/lang/String::getBytes (//.name //.utf_8) value) + + @.js + (cond ffi.on_nashorn? + (:as Binary ("js object do" "getBytes" value ["utf8"])) + + ffi.on_node_js? + (|> (Buffer::from|encode [value "utf8"]) + ## This coercion is valid as per NodeJS's documentation: + ## https://nodejs.org/api/buffer.html#buffer_buffers_and_typedarrays + (:as Uint8Array)) + + ## On the browser + (|> (TextEncoder::new [(//.name //.utf_8)]) + (TextEncoder::encode [value])) + ) + + @.python + (:as Binary ("python apply" (:assume ("python constant" "bytearray")) value "utf-8")) + + @.lua + ("lua utf8 encode" value) + + @.ruby + (|> value + (:as RubyString) + (RubyString::encode ["UTF-8"]) + (RubyString::bytes [])) + + @.php + (|> (..unpack [..php_byte_array_format value]) + ..array_values + ("php object new" "ArrayObject") + (:as Binary)) + + @.scheme + (..string->utf8 value)})) + +(def: (decode value) + (-> Binary (Try Text)) + (with_expansions [<jvm> (#try.Success (java/lang/String::new value (//.name //.utf_8)))] + (for {@.old <jvm> + @.jvm <jvm> + + @.js + (cond ffi.on_nashorn? + (|> ("js object new" ("js constant" "java.lang.String") [value "utf8"]) + (:as Text) + #try.Success) + + ffi.on_node_js? + (|> (Buffer::from|decode [value]) + (Buffer::toString ["utf8"]) + #try.Success) + + ## On the browser + (|> (TextDecoder::new [(//.name //.utf_8)]) + (TextDecoder::decode [value]) + #try.Success)) + + @.python + (try (:as Text ("python object do" "decode" (:assume value) "utf-8"))) + + @.lua + (#try.Success ("lua utf8 decode" value)) + + @.ruby + (|> value + (:as RubyArray) + (RubyArray::pack ["C*"]) + (:as RubyString) + (RubyString::force_encoding ["UTF-8"]) + #try.Success) + + @.php + (|> value + ("php pack" ..php_byte_array_format) + #try.Success) + + @.scheme + (|> value + ..utf8->string + #try.Success)}))) + +(implementation: #export codec + (Codec Binary Text) + + (def: encode ..encode) + (def: decode ..decode)) diff --git a/stdlib/source/library/lux/data/text/escape.lux b/stdlib/source/library/lux/data/text/escape.lux new file mode 100644 index 000000000..2e9883c78 --- /dev/null +++ b/stdlib/source/library/lux/data/text/escape.lux @@ -0,0 +1,244 @@ +(.module: + [library + [lux #* + ["." meta] + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" code]]] + [data + ["." maybe]] + [math + [number (#+ hex) + ["n" nat]]] + [macro + [syntax (#+ syntax:)] + ["." code]]]] + ["." // (#+ Char) + ["%" format (#+ format)]]) + +(def: sigil "\") + +(template [<char> <sigil>] + [(def: <char> + (|> <sigil> (//.nth 0) maybe.assume))] + + [sigil_char ..sigil] + [\u_sigil "u"] + ) + +(template [<literal> <sigil> <escaped>] + [(def: <sigil> + (|> <literal> (//.nth 0) maybe.assume)) + + (def: <escaped> + (format ..sigil <literal>))] + + ["0" \0_sigil escaped_\0] + ["a" \a_sigil escaped_\a] + ["b" \b_sigil escaped_\b] + ["t" \t_sigil escaped_\t] + ["n" \n_sigil escaped_\n] + ["v" \v_sigil escaped_\v] + ["f" \f_sigil escaped_\f] + ["r" \r_sigil escaped_\r] + [//.\'' \''_sigil escaped_\''] + [..sigil \\_sigil escaped_\\] + ) + +(template [<char> <text>] + [(def: <char> + (|> <text> (//.nth 0) maybe.assume))] + + [\0 //.\0] + [\a //.\a] + [\b //.\b] + [\t //.\t] + [\n //.\n] + [\v //.\v] + [\f //.\f] + [\r //.\r] + [\'' //.\''] + [\\ ..sigil] + ) + +(def: ascii_bottom (hex "20")) +(def: ascii_top (hex "7E")) + +(def: #export (escapable? char) + (-> Char Bit) + (case char + (^template [<char>] + [(^ (static <char>)) + true]) + ([..\0] [..\a] [..\b] [..\t] + [..\n] [..\v] [..\f] [..\r] + [..\''] [..\\]) + + _ + (or (n.< ..ascii_bottom char) + (n.> ..ascii_top char)))) + +(def: (ascii_escape replacement pre_offset pre_limit previous current) + (-> Text Nat Nat Text Text [Text Text Nat]) + (let [post_offset (inc pre_offset) + post_limit (n.- post_offset pre_limit)] + [(format previous + ("lux text clip" 0 pre_offset current) + replacement) + ("lux text clip" post_offset post_limit current) + post_limit])) + +(def: (unicode_escape char pre_offset pre_limit previous current) + (-> Char Nat Nat Text Text [Text Text Nat]) + (let [code (\ n.hex encode char) + replacement (format ..sigil "u" + (case ("lux text size" code) + 1 (format "000" code) + 2 (format "00" code) + 3 (format "0" code) + _ code)) + post_offset (inc pre_offset) + post_limit (n.- post_offset pre_limit)] + [(format previous + ("lux text clip" 0 pre_offset current) + replacement) + ("lux text clip" post_offset post_limit current) + post_limit])) + +(def: #export (escape text) + (-> Text Text) + (loop [offset 0 + previous "" + current text + limit ("lux text size" text)] + (if (n.< limit offset) + (case ("lux text char" offset current) + (^template [<char> <replacement>] + [(^ (static <char>)) + (let [[previous' current' limit'] (ascii_escape <replacement> offset limit previous current)] + (recur 0 previous' current' limit'))]) + ([..\0 ..escaped_\0] + [..\a ..escaped_\a] + [..\b ..escaped_\b] + [..\t ..escaped_\t] + [..\n ..escaped_\n] + [..\v ..escaped_\v] + [..\f ..escaped_\f] + [..\r ..escaped_\r] + [..\'' ..escaped_\''] + [..\\ ..escaped_\\]) + + char + (if (or (n.< ..ascii_bottom char) + (n.> ..ascii_top char)) + (let [[previous' current' limit'] (unicode_escape char offset limit previous current)] + (recur 0 previous' current' limit')) + (recur (inc offset) previous current limit))) + (format previous current)))) + +(exception: #export (dangling_escape {text Text}) + (exception.report + ["In" (%.text text)] + ["At" (%.nat (dec (//.size text)))])) + +(exception: #export (invalid_escape {text Text} {offset Nat} {sigil Char}) + (exception.report + ["In" (%.text text)] + ["At" (%.nat offset)] + ["Name" (%.text (//.from_code sigil))])) + +(exception: #export (invalid_unicode_escape {text Text} {offset Nat}) + (exception.report + ["In" (%.text text)] + ["At" (%.nat offset)])) + +(def: code_size + 4) + +(def: ascii_escape_offset + 2) + +(def: unicode_escape_offset + (n.+ ..ascii_escape_offset ..code_size)) + +(def: (ascii_un_escape replacement offset previous current limit) + (-> Text Nat Text Text Nat [Text Text Nat]) + (let [limit' (|> limit (n.- offset) (n.- ..ascii_escape_offset))] + [(format previous + ("lux text clip" 0 offset current) + replacement) + ("lux text clip" (n.+ ..ascii_escape_offset offset) limit' current) + limit'])) + +(def: (unicode_un_escape offset previous current limit) + (-> Nat Text Text Nat (Try [Text Text Nat])) + (case (|> current + ("lux text clip" (n.+ ..ascii_escape_offset offset) ..code_size) + (\ n.hex decode)) + (#try.Success char) + (let [limit' (|> limit (n.- offset) (n.- ..unicode_escape_offset))] + (#try.Success [(format previous + ("lux text clip" 0 offset current) + (//.from_code char)) + ("lux text clip" (n.+ ..unicode_escape_offset offset) limit' current) + limit'])) + + (#try.Failure error) + (exception.throw ..invalid_unicode_escape [current offset]))) + +(def: #export (un_escape text) + (-> Text (Try Text)) + (loop [offset 0 + previous "" + current text + limit ("lux text size" text)] + (if (n.< limit offset) + (case ("lux text char" offset current) + (^ (static ..sigil_char)) + (let [@sigil (inc offset)] + (if (n.< limit @sigil) + (case ("lux text char" @sigil current) + (^template [<sigil> <un_escaped>] + [(^ (static <sigil>)) + (let [[previous' current' limit'] (..ascii_un_escape <un_escaped> offset previous current limit)] + (recur 0 previous' current' limit'))]) + ([..\0_sigil //.\0] + [..\a_sigil //.\a] + [..\b_sigil //.\b] + [..\t_sigil //.\t] + [..\n_sigil //.\n] + [..\v_sigil //.\v] + [..\f_sigil //.\f] + [..\r_sigil //.\r] + [..\''_sigil //.\''] + [..\\_sigil ..sigil]) + + (^ (static ..\u_sigil)) + (let [@unicode (n.+ code_size @sigil)] + (if (n.< limit @unicode) + (do try.monad + [[previous' current' limit'] (..unicode_un_escape offset previous current limit)] + (recur 0 previous' current' limit')) + (exception.throw ..invalid_unicode_escape [text offset]))) + + invalid_sigil + (exception.throw ..invalid_escape [text offset invalid_sigil])) + (exception.throw ..dangling_escape [text]))) + + _ + (recur (inc offset) previous current limit)) + (#try.Success (case previous + "" current + _ (format previous current)))))) + +(syntax: #export (escaped {literal <code>.text}) + (case (..un_escape literal) + (#try.Success un_escaped) + (wrap (list (code.text un_escaped))) + + (#try.Failure error) + (meta.fail error))) diff --git a/stdlib/source/library/lux/data/text/format.lux b/stdlib/source/library/lux/data/text/format.lux new file mode 100644 index 000000000..a80503d36 --- /dev/null +++ b/stdlib/source/library/lux/data/text/format.lux @@ -0,0 +1,135 @@ +(.module: + [library + [lux (#- list nat int rev type) + [abstract + [monad (#+ do)] + [functor + ["." contravariant]]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]]] + [data + ["." bit] + ["." name] + ["." text] + [format + ["." xml] + ["." json]] + [collection + ["." list ("#\." monad)]]] + ["." time + ["." instant] + ["." duration] + ["." date] + ["." day] + ["." month]] + [math + ["." modular] + [number + ["." nat] + ["." int] + ["." rev] + ["." frac] + ["." ratio]]] + [macro + [syntax (#+ syntax:)] + ["." code] + ["." template]] + [meta + ["." location]] + ["." type]]]) + +(type: #export (Format a) + {#.doc "A way to produce readable text from values."} + (-> a Text)) + +(implementation: #export functor + (contravariant.Functor Format) + + (def: (map f fb) + (|>> f fb))) + +(syntax: #export (format {fragments (<>.many <c>.any)}) + {#.doc (doc "Text interpolation." + (format "Static part " (text static) " does not match URI: " uri))} + (wrap (.list (` ($_ "lux text concat" (~+ fragments)))))) + +(template [<name> <type> <formatter>] + [(def: #export <name> + (Format <type>) + <formatter>)] + + [bit Bit (\ bit.codec encode)] + [nat Nat (\ nat.decimal encode)] + [int Int (\ int.decimal encode)] + [rev Rev (\ rev.decimal encode)] + [frac Frac (\ frac.decimal encode)] + [text Text text.format] + + [ratio ratio.Ratio (\ ratio.codec encode)] + [name Name (\ name.codec encode)] + [location Location location.format] + [code Code code.format] + [type Type type.format] + + [instant instant.Instant (\ instant.codec encode)] + [duration duration.Duration (\ duration.codec encode)] + [date date.Date (\ date.codec encode)] + [time time.Time (\ time.codec encode)] + [day day.Day (\ day.codec encode)] + [month month.Month (\ month.codec encode)] + + [xml xml.XML (\ xml.codec encode)] + [json json.JSON (\ json.codec encode)] + ) + +(template [<type> <format>,<codec>] + [(`` (template [<format> <codec>] + [(def: #export <format> + (Format <type>) + (\ <codec> encode))] + + (~~ (template.splice <format>,<codec>))))] + + [Nat + [[nat/2 nat.binary] + [nat/8 nat.octal] + [nat/10 nat.decimal] + [nat/16 nat.hex]]] + [Int + [[int/2 int.binary] + [int/8 int.octal] + [int/10 int.decimal] + [int/16 int.hex]]] + [Rev + [[rev/2 rev.binary] + [rev/8 rev.octal] + [rev/10 rev.decimal] + [rev/16 rev.hex]]] + [Frac + [[frac/2 frac.binary] + [frac/8 frac.octal] + [frac/10 frac.decimal] + [frac/16 frac.hex]]] + ) + +(def: #export (mod modular) + (All [m] (Format (modular.Mod m))) + (let [codec (modular.codec (modular.modulus modular))] + (\ codec encode modular))) + +(def: #export (list formatter) + (All [a] (-> (Format a) (Format (List a)))) + (|>> (list\map (|>> formatter (format " "))) + (text.join_with "") + (text.enclose ["(list" ")"]))) + +(def: #export (maybe format) + (All [a] (-> (Format a) (Format (Maybe a)))) + (function (_ value) + (case value + #.None + "#.None" + + (#.Some value) + (..format "(#.Some " (format value) ")")))) diff --git a/stdlib/source/library/lux/data/text/regex.lux b/stdlib/source/library/lux/data/text/regex.lux new file mode 100644 index 000000000..38f4155ab --- /dev/null +++ b/stdlib/source/library/lux/data/text/regex.lux @@ -0,0 +1,495 @@ +(.module: + [library + [lux #* + ["." meta] + [abstract + monad] + [control + ["." try] + ["<>" parser ("#\." monad) + ["<t>" text (#+ Parser)] + ["<c>" code]]] + [data + ["." product] + ["." maybe] + [collection + ["." list ("#\." fold monad)]]] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["n" nat ("#\." decimal)]]]]] + ["." // + ["%" format (#+ format)]]) + +(def: regex_char^ + (Parser Text) + (<t>.none_of "\.|&()[]{}")) + +(def: escaped_char^ + (Parser Text) + (do <>.monad + [? (<>.parses? (<t>.this "\"))] + (if ? + <t>.any + regex_char^))) + +(def: (refine^ refinement^ base^) + (All [a] (-> (Parser a) (Parser Text) (Parser Text))) + (do <>.monad + [output base^ + _ (<t>.local output refinement^)] + (wrap output))) + +(def: word^ + (Parser Text) + (<>.either <t>.alpha_num + (<t>.one_of "_"))) + +(def: (copy reference) + (-> Text (Parser Text)) + (<>.after (<t>.this reference) (<>\wrap reference))) + +(def: (join_text^ part^) + (-> (Parser (List Text)) (Parser Text)) + (do <>.monad + [parts part^] + (wrap (//.join_with "" parts)))) + +(def: name_char^ + (Parser Text) + (<t>.none_of (format "[]{}()s#.<>" //.double_quote))) + +(def: name_part^ + (Parser Text) + (do <>.monad + [head (refine^ (<t>.not <t>.decimal) + name_char^) + tail (<t>.some name_char^)] + (wrap (format head tail)))) + +(def: (name^ current_module) + (-> Text (Parser Name)) + ($_ <>.either + (<>.and (<>\wrap current_module) (<>.after (<t>.this "..") name_part^)) + (<>.and name_part^ (<>.after (<t>.this ".") name_part^)) + (<>.and (<>\wrap .prelude_module) (<>.after (<t>.this ".") name_part^)) + (<>.and (<>\wrap "") name_part^))) + +(def: (re_var^ current_module) + (-> Text (Parser Code)) + (do <>.monad + [name (<t>.enclosed ["\@<" ">"] (name^ current_module))] + (wrap (` (: (Parser Text) (~ (code.identifier name))))))) + +(def: re_range^ + (Parser Code) + (do {! <>.monad} + [from (|> regex_char^ (\ ! map (|>> (//.nth 0) maybe.assume))) + _ (<t>.this "-") + to (|> regex_char^ (\ ! map (|>> (//.nth 0) maybe.assume)))] + (wrap (` (<t>.range (~ (code.nat from)) (~ (code.nat to))))))) + +(def: re_char^ + (Parser Code) + (do <>.monad + [char escaped_char^] + (wrap (` ((~! ..copy) (~ (code.text char))))))) + +(def: re_options^ + (Parser Code) + (do <>.monad + [options (<t>.many escaped_char^)] + (wrap (` (<t>.one_of (~ (code.text options))))))) + +(def: re_user_class^' + (Parser Code) + (do <>.monad + [negate? (<>.maybe (<t>.this "^")) + parts (<>.many ($_ <>.either + re_range^ + re_options^))] + (wrap (case negate? + (#.Some _) (` (<t>.not ($_ <>.either (~+ parts)))) + #.None (` ($_ <>.either (~+ parts))))))) + +(def: re_user_class^ + (Parser Code) + (do <>.monad + [_ (wrap []) + init re_user_class^' + rest (<>.some (<>.after (<t>.this "&&") (<t>.enclosed ["[" "]"] re_user_class^')))] + (wrap (list\fold (function (_ refinement base) + (` ((~! refine^) (~ refinement) (~ base)))) + init + rest)))) + +(def: blank^ + (Parser Text) + (<t>.one_of (format " " //.tab))) + +(def: ascii^ + (Parser Text) + (<t>.range (hex "0") (hex "7F"))) + +(def: control^ + (Parser Text) + (<>.either (<t>.range (hex "0") (hex "1F")) + (<t>.one_of (//.from_code (hex "7F"))))) + +(def: punct^ + (Parser Text) + (<t>.one_of (format "!#$%&'()*+,-./:;<=>?@[\]^_`{|}~" + //.double_quote))) + +(def: graph^ + (Parser Text) + (<>.either punct^ <t>.alpha_num)) + +(def: print^ + (Parser Text) + (<>.either graph^ + (<t>.one_of (//.from_code (hex "20"))))) + +(def: re_system_class^ + (Parser Code) + (do <>.monad + [] + ($_ <>.either + (<>.after (<t>.this ".") (wrap (` <t>.any))) + (<>.after (<t>.this "\d") (wrap (` <t>.decimal))) + (<>.after (<t>.this "\D") (wrap (` (<t>.not <t>.decimal)))) + (<>.after (<t>.this "\s") (wrap (` <t>.space))) + (<>.after (<t>.this "\S") (wrap (` (<t>.not <t>.space)))) + (<>.after (<t>.this "\w") (wrap (` (~! word^)))) + (<>.after (<t>.this "\W") (wrap (` (<t>.not (~! word^))))) + + (<>.after (<t>.this "\p{Lower}") (wrap (` <t>.lower))) + (<>.after (<t>.this "\p{Upper}") (wrap (` <t>.upper))) + (<>.after (<t>.this "\p{Alpha}") (wrap (` <t>.alpha))) + (<>.after (<t>.this "\p{Digit}") (wrap (` <t>.decimal))) + (<>.after (<t>.this "\p{Alnum}") (wrap (` <t>.alpha_num))) + (<>.after (<t>.this "\p{Space}") (wrap (` <t>.space))) + (<>.after (<t>.this "\p{HexDigit}") (wrap (` <t>.hexadecimal))) + (<>.after (<t>.this "\p{OctDigit}") (wrap (` <t>.octal))) + (<>.after (<t>.this "\p{Blank}") (wrap (` (~! blank^)))) + (<>.after (<t>.this "\p{ASCII}") (wrap (` (~! ascii^)))) + (<>.after (<t>.this "\p{Contrl}") (wrap (` (~! control^)))) + (<>.after (<t>.this "\p{Punct}") (wrap (` (~! punct^)))) + (<>.after (<t>.this "\p{Graph}") (wrap (` (~! graph^)))) + (<>.after (<t>.this "\p{Print}") (wrap (` (~! print^)))) + ))) + +(def: re_class^ + (Parser Code) + (<>.either re_system_class^ + (<t>.enclosed ["[" "]"] re_user_class^))) + +(def: number^ + (Parser Nat) + (|> (<t>.many <t>.decimal) + (<>.codec n.decimal))) + +(def: re_back_reference^ + (Parser Code) + (<>.either (do <>.monad + [_ (<t>.this "\") + id number^] + (wrap (` ((~! ..copy) (~ (code.identifier ["" (n\encode id)])))))) + (do <>.monad + [_ (<t>.this "\k<") + captured_name name_part^ + _ (<t>.this ">")] + (wrap (` ((~! ..copy) (~ (code.identifier ["" captured_name])))))))) + +(def: (re_simple^ current_module) + (-> Text (Parser Code)) + ($_ <>.either + re_class^ + (re_var^ current_module) + re_back_reference^ + re_char^ + )) + +(def: (re_simple_quantified^ current_module) + (-> Text (Parser Code)) + (do <>.monad + [base (re_simple^ current_module) + quantifier (<t>.one_of "?*+")] + (case quantifier + "?" + (wrap (` (<>.default "" (~ base)))) + + "*" + (wrap (` ((~! join_text^) (<>.some (~ base))))) + + ## "+" + _ + (wrap (` ((~! join_text^) (<>.many (~ base))))) + ))) + +(def: (re_counted_quantified^ current_module) + (-> Text (Parser Code)) + (do {! <>.monad} + [base (re_simple^ current_module)] + (<t>.enclosed ["{" "}"] + ($_ <>.either + (do ! + [[from to] (<>.and number^ (<>.after (<t>.this ",") number^))] + (wrap (` ((~! join_text^) (<>.between (~ (code.nat from)) + (~ (code.nat to)) + (~ base)))))) + (do ! + [limit (<>.after (<t>.this ",") number^)] + (wrap (` ((~! join_text^) (<>.at_most (~ (code.nat limit)) (~ base)))))) + (do ! + [limit (<>.before (<t>.this ",") number^)] + (wrap (` ((~! join_text^) (<>.at_least (~ (code.nat limit)) (~ base)))))) + (do ! + [limit number^] + (wrap (` ((~! join_text^) (<>.exactly (~ (code.nat limit)) (~ base)))))))))) + +(def: (re_quantified^ current_module) + (-> Text (Parser Code)) + (<>.either (re_simple_quantified^ current_module) + (re_counted_quantified^ current_module))) + +(def: (re_complex^ current_module) + (-> Text (Parser Code)) + ($_ <>.either + (re_quantified^ current_module) + (re_simple^ current_module))) + +(type: Re_Group + #Non_Capturing + (#Capturing [(Maybe Text) Nat])) + +(def: (re_sequential^ capturing? re_scoped^ current_module) + (-> Bit + (-> Text (Parser [Re_Group Code])) + Text + (Parser [Nat Code])) + (do <>.monad + [parts (<>.many (<>.or (re_complex^ current_module) + (re_scoped^ current_module))) + #let [g!total (code.identifier ["" "0total"]) + g!temp (code.identifier ["" "0temp"]) + [_ names steps] (list\fold (: (-> (Either Code [Re_Group Code]) + [Nat (List Code) (List (List Code))] + [Nat (List Code) (List (List Code))]) + (function (_ part [idx names steps]) + (case part + (^or (#.Left complex) (#.Right [#Non_Capturing complex])) + [idx + names + (list& (list g!temp complex + (' #let) (` [(~ g!total) (\ (~! //.monoid) (~' compose) (~ g!total) (~ g!temp))])) + steps)] + + (#.Right [(#Capturing [?name num_captures]) scoped]) + (let [[idx! name!] (case ?name + (#.Some _name) + [idx (code.identifier ["" _name])] + + #.None + [(inc idx) (code.identifier ["" (n\encode idx)])]) + access (if (n.> 0 num_captures) + (` ((~! product.left) (~ name!))) + name!)] + [idx! + (list& name! names) + (list& (list name! scoped + (' #let) (` [(~ g!total) (\ (~! //.monoid) (~' compose) (~ g!total) (~ access))])) + steps)]) + ))) + [0 + (: (List Code) (list)) + (: (List (List Code)) (list))] + parts)]] + (wrap [(if capturing? + (list.size names) + 0) + (` (do <>.monad + [(~ (' #let)) [(~ g!total) ""] + (~+ (|> steps list.reverse list\join))] + ((~ (' wrap)) [(~ g!total) (~+ (list.reverse names))])))]) + )) + +(def: (unflatten^ lexer) + (-> (Parser Text) (Parser [Text Any])) + (<>.and lexer (\ <>.monad wrap []))) + +(def: (|||^ left right) + (All [l r] (-> (Parser [Text l]) (Parser [Text r]) (Parser [Text (| l r)]))) + (function (_ input) + (case (left input) + (#try.Success [input' [lt lv]]) + (#try.Success [input' [lt (0 #0 lv)]]) + + (#try.Failure _) + (case (right input) + (#try.Success [input' [rt rv]]) + (#try.Success [input' [rt (0 #1 rv)]]) + + (#try.Failure error) + (#try.Failure error))))) + +(def: (|||_^ left right) + (All [l r] (-> (Parser [Text l]) (Parser [Text r]) (Parser Text))) + (function (_ input) + (case (left input) + (#try.Success [input' [lt lv]]) + (#try.Success [input' lt]) + + (#try.Failure _) + (case (right input) + (#try.Success [input' [rt rv]]) + (#try.Success [input' rt]) + + (#try.Failure error) + (#try.Failure error))))) + +(def: (prep_alternative [num_captures alt]) + (-> [Nat Code] Code) + (if (n.> 0 num_captures) + alt + (` ((~! unflatten^) (~ alt))))) + +(def: (re_alternative^ capturing? re_scoped^ current_module) + (-> Bit + (-> Text (Parser [Re_Group Code])) + Text + (Parser [Nat Code])) + (do <>.monad + [#let [sub^ (re_sequential^ capturing? re_scoped^ current_module)] + head sub^ + tail (<>.some (<>.after (<t>.this "|") sub^))] + (if (list.empty? tail) + (wrap head) + (wrap [(list\fold n.max (product.left head) (list\map product.left tail)) + (` ($_ ((~ (if capturing? + (` (~! |||^)) + (` (~! |||_^))))) + (~ (prep_alternative head)) + (~+ (list\map prep_alternative tail))))])))) + +(def: (re_scoped^ current_module) + (-> Text (Parser [Re_Group Code])) + ($_ <>.either + (do <>.monad + [_ (<t>.this "(?:") + [_ scoped] (re_alternative^ #0 re_scoped^ current_module) + _ (<t>.this ")")] + (wrap [#Non_Capturing scoped])) + (do <>.monad + [complex (re_complex^ current_module)] + (wrap [#Non_Capturing complex])) + (do <>.monad + [_ (<t>.this "(?<") + captured_name name_part^ + _ (<t>.this ">") + [num_captures pattern] (re_alternative^ #1 re_scoped^ current_module) + _ (<t>.this ")")] + (wrap [(#Capturing [(#.Some captured_name) num_captures]) pattern])) + (do <>.monad + [_ (<t>.this "(") + [num_captures pattern] (re_alternative^ #1 re_scoped^ current_module) + _ (<t>.this ")")] + (wrap [(#Capturing [#.None num_captures]) pattern])))) + +(def: (regex^ current_module) + (-> Text (Parser Code)) + (\ <>.monad map product.right (re_alternative^ #1 re_scoped^ current_module))) + +(syntax: #export (regex {pattern <c>.text}) + {#.doc (doc "Create lexers using regular-expression syntax." + "For example:" + + "Literals" + (regex "a") + + "Wildcards" + (regex ".") + + "Escaping" + (regex "\.") + + "Character classes" + (regex "\d") + (regex "\p{Lower}") + (regex "[abc]") + (regex "[a-z]") + (regex "[a-zA-Z]") + (regex "[a-z&&[def]]") + + "Negation" + (regex "[^abc]") + (regex "[^a-z]") + (regex "[^a-zA-Z]") + (regex "[a-z&&[^bc]]") + (regex "[a-z&&[^m-p]]") + + "Combinations" + (regex "aa") + (regex "a?") + (regex "a*") + (regex "a+") + + "Specific amounts" + (regex "a{2}") + + "At least" + (regex "a{1,}") + + "At most" + (regex "a{,1}") + + "Between" + (regex "a{1,2}") + + "Groups" + (regex "a(.)c") + (regex "a(b+)c") + (regex "(\d{3})-(\d{3})-(\d{4})") + (regex "(\d{3})-(?:\d{3})-(\d{4})") + (regex "(?<code>\d{3})-\k<code>-(\d{4})") + (regex "(?<code>\d{3})-\k<code>-(\d{4})-\0") + (regex "(\d{3})-((\d{3})-(\d{4}))") + + "Alternation" + (regex "a|b") + (regex "a(.)(.)|b(.)(.)") + )} + (do meta.monad + [current_module meta.current_module_name] + (case (<t>.run (regex^ current_module) + pattern) + (#try.Failure error) + (meta.fail (format "Error while parsing regular-expression:" //.new_line + error)) + + (#try.Success regex) + (wrap (list regex)) + ))) + +(syntax: #export (^regex {[pattern bindings] (<c>.form (<>.and <c>.text (<>.maybe <c>.any)))} + body + {branches (<>.many <c>.any)}) + {#.doc (doc "Allows you to test text against regular expressions." + (case some_text + (^regex "(\d{3})-(\d{3})-(\d{4})" + [_ country_code area_code place_code]) + do_some_thing_when_number + + (^regex "\w+") + do_some_thing_when_word + + _ + do_something_else))} + (with_gensyms [g!temp] + (wrap (list& (` (^multi (~ g!temp) + [((~! <t>.run) (..regex (~ (code.text pattern))) (~ g!temp)) + (#try.Success (~ (maybe.default g!temp bindings)))])) + body + branches)))) diff --git a/stdlib/source/library/lux/data/text/unicode/block.lux b/stdlib/source/library/lux/data/text/unicode/block.lux new file mode 100644 index 000000000..24ddb34e2 --- /dev/null +++ b/stdlib/source/library/lux/data/text/unicode/block.lux @@ -0,0 +1,205 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + [monoid (#+ Monoid)] + ["." interval (#+ Interval)]] + [math + [number (#+ hex) + ["n" nat ("#\." interval)] + ["." i64]]] + [type + abstract]]] + [/// (#+ Char)]) + +(abstract: #export Block + (Interval Char) + + (implementation: #export monoid + (Monoid Block) + + (def: identity + (:abstraction (interval.between n.enum n\top n\bottom))) + (def: (compose left right) + (let [left (:representation left) + right (:representation right)] + (:abstraction + (interval.between n.enum + (n.min (\ left bottom) + (\ right bottom)) + (n.max (\ left top) + (\ right top))))))) + + (def: #export (block start end) + (-> Char Char Block) + (:abstraction (interval.between n.enum (n.min start end) (n.max start end)))) + + (template [<name> <slot>] + [(def: #export <name> + (-> Block Char) + (|>> :representation (get@ <slot>)))] + + [start #interval.bottom] + [end #interval.top] + ) + + (def: #export (size block) + (-> Block Nat) + (let [start (get@ #interval.bottom (:representation block)) + end (get@ #interval.top (:representation block))] + (|> end (n.- start) inc))) + + (def: #export (within? block char) + (All [a] (-> Block Char Bit)) + (interval.within? (:representation block) char)) + ) + +(implementation: #export equivalence + (Equivalence Block) + + (def: (= reference subject) + (and (n.= (..start reference) (..start subject)) + (n.= (..end reference) (..end subject))))) + +(implementation: #export hash + (Hash Block) + + (def: &equivalence ..equivalence) + (def: (hash value) + (i64.or (i64.left_shift 32 (..start value)) + (..end value)))) + +(template [<name> <start> <end>] + [(def: #export <name> Block (..block (hex <start>) (hex <end>)))] + + ## Normal blocks + [basic_latin "0000" "007F"] + [latin_1_supplement "00A0" "00FF"] + [latin_extended_a "0100" "017F"] + [latin_extended_b "0180" "024F"] + [ipa_extensions "0250" "02AF"] + [spacing_modifier_letters "02B0" "02FF"] + [combining_diacritical_marks "0300" "036F"] + [greek_and_coptic "0370" "03FF"] + [cyrillic "0400" "04FF"] + [cyrillic_supplementary "0500" "052F"] + [armenian "0530" "058F"] + [hebrew "0590" "05FF"] + [arabic "0600" "06FF"] + [syriac "0700" "074F"] + [thaana "0780" "07BF"] + [devanagari "0900" "097F"] + [bengali "0980" "09FF"] + [gurmukhi "0A00" "0A7F"] + [gujarati "0A80" "0AFF"] + [oriya "0B00" "0B7F"] + [tamil "0B80" "0BFF"] + [telugu "0C00" "0C7F"] + [kannada "0C80" "0CFF"] + [malayalam "0D00" "0D7F"] + [sinhala "0D80" "0DFF"] + [thai "0E00" "0E7F"] + [lao "0E80" "0EFF"] + [tibetan "0F00" "0FFF"] + [myanmar "1000" "109F"] + [georgian "10A0" "10FF"] + [hangul_jamo "1100" "11FF"] + [ethiopic "1200" "137F"] + [cherokee "13A0" "13FF"] + [unified_canadian_aboriginal_syllabics "1400" "167F"] + [ogham "1680" "169F"] + [runic "16A0" "16FF"] + [tagalog "1700" "171F"] + [hanunoo "1720" "173F"] + [buhid "1740" "175F"] + [tagbanwa "1760" "177F"] + [khmer "1780" "17FF"] + [mongolian "1800" "18AF"] + [limbu "1900" "194F"] + [tai_le "1950" "197F"] + [khmer_symbols "19E0" "19FF"] + [phonetic_extensions "1D00" "1D7F"] + [latin_extended_additional "1E00" "1EFF"] + [greek_extended "1F00" "1FFF"] + [general_punctuation "2000" "206F"] + [superscripts_and_subscripts "2070" "209F"] + [currency_symbols "20A0" "20CF"] + [combining_diacritical_marks_for_symbols "20D0" "20FF"] + [letterlike_symbols "2100" "214F"] + [number_forms "2150" "218F"] + [arrows "2190" "21FF"] + [mathematical_operators "2200" "22FF"] + [miscellaneous_technical "2300" "23FF"] + [control_pictures "2400" "243F"] + [optical_character_recognition "2440" "245F"] + [enclosed_alphanumerics "2460" "24FF"] + [box_drawing "2500" "257F"] + [block_elements "2580" "259F"] + [geometric_shapes "25A0" "25FF"] + [miscellaneous_symbols "2600" "26FF"] + [dingbats "2700" "27BF"] + [miscellaneous_mathematical_symbols_a "27C0" "27EF"] + [supplemental_arrows_a "27F0" "27FF"] + [braille_patterns "2800" "28FF"] + [supplemental_arrows_b "2900" "297F"] + [miscellaneous_mathematical_symbols_b "2980" "29FF"] + [supplemental_mathematical_operators "2A00" "2AFF"] + [miscellaneous_symbols_and_arrows "2B00" "2BFF"] + [cjk_radicals_supplement "2E80" "2EFF"] + [kangxi_radicals "2F00" "2FDF"] + [ideographic_description_characters "2FF0" "2FFF"] + [cjk_symbols_and_punctuation "3000" "303F"] + [hiragana "3040" "309F"] + [katakana "30A0" "30FF"] + [bopomofo "3100" "312F"] + [hangul_compatibility_jamo "3130" "318F"] + [kanbun "3190" "319F"] + [bopomofo_extended "31A0" "31BF"] + [katakana_phonetic_extensions "31F0" "31FF"] + [enclosed_cjk_letters_and_months "3200" "32FF"] + [cjk_compatibility "3300" "33FF"] + [cjk_unified_ideographs_extension_a "3400" "4DBF"] + [yijing_hexagram_symbols "4DC0" "4DFF"] + [cjk_unified_ideographs "4E00" "9FFF"] + [yi_syllables "A000" "A48F"] + [yi_radicals "A490" "A4CF"] + [hangul_syllables "AC00" "D7AF"] + [high_surrogates "D800" "DB7F"] + [high_private_use_surrogates "DB80" "DBFF"] + [low_surrogates "DC00" "DFFF"] + [private_use_area "E000" "F8FF"] + [cjk_compatibility_ideographs "F900" "FAFF"] + [alphabetic_presentation_forms "FB00" "FB4F"] + [arabic_presentation_forms_a "FB50" "FDFF"] + [variation_selectors "FE00" "FE0F"] + [combining_half_marks "FE20" "FE2F"] + [cjk_compatibility_forms "FE30" "FE4F"] + [small_form_variants "FE50" "FE6F"] + [arabic_presentation_forms_b "FE70" "FEFF"] + [halfwidth_and_fullwidth_forms "FF00" "FFEF"] + [specials "FFF0" "FFFF"] + ## [linear_b_syllabary "10000" "1007F"] + ## [linear_b_ideograms "10080" "100FF"] + ## [aegean_numbers "10100" "1013F"] + ## [old_italic "10300" "1032F"] + ## [gothic "10330" "1034F"] + ## [ugaritic "10380" "1039F"] + ## [deseret "10400" "1044F"] + ## [shavian "10450" "1047F"] + ## [osmanya "10480" "104AF"] + ## [cypriot_syllabary "10800" "1083F"] + ## [byzantine_musical_symbols "1D000" "1D0FF"] + ## [musical_symbols "1D100" "1D1FF"] + ## [tai_xuan_jing_symbols "1D300" "1D35F"] + ## [mathematical_alphanumeric_symbols "1D400" "1D7FF"] + ## [cjk_unified_ideographs_extension_b "20000" "2A6DF"] + ## [cjk_compatibility_ideographs_supplement "2F800" "2FA1F"] + ## [tags "E0000" "E007F"] + + ## Specialized blocks + [basic_latin/decimal "0030" "0039"] + [basic_latin/upper "0041" "005A"] + [basic_latin/lower "0061" "007A"] + ) diff --git a/stdlib/source/library/lux/data/text/unicode/set.lux b/stdlib/source/library/lux/data/text/unicode/set.lux new file mode 100644 index 000000000..2c48aed41 --- /dev/null +++ b/stdlib/source/library/lux/data/text/unicode/set.lux @@ -0,0 +1,240 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [data + [collection + ["." list ("#\." fold functor)] + ["." set ("#\." equivalence)] + ["." tree #_ + ["#" finger (#+ Tree)]]]] + [type (#+ :by_example) + abstract]]] + ["." / #_ + ["/#" // #_ + [// (#+ Char)] + ["#." block (#+ Block)]]]) + +(def: builder + (tree.builder //block.monoid)) + +(def: :@: + (:by_example [@] + (tree.Builder @ Block) + ..builder + + @)) + +(abstract: #export Set + (Tree :@: Block []) + + (def: #export (compose left right) + (-> Set Set Set) + (:abstraction + (\ builder branch + (:representation left) + (:representation right)))) + + (def: (singleton block) + (-> Block Set) + (:abstraction + (\ builder leaf block []))) + + (def: #export (set [head tail]) + (-> [Block (List Block)] Set) + (list\fold (: (-> Block Set Set) + (function (_ block set) + (..compose (..singleton block) set))) + (..singleton head) + tail)) + + (def: character/0 + Set + (..set [//block.basic_latin + (list //block.latin_1_supplement + //block.latin_extended_a + //block.latin_extended_b + //block.ipa_extensions + //block.spacing_modifier_letters + //block.combining_diacritical_marks + //block.greek_and_coptic + //block.cyrillic + //block.cyrillic_supplementary + //block.armenian + //block.hebrew + //block.arabic + //block.syriac + //block.thaana + //block.devanagari + //block.bengali + //block.gurmukhi + //block.gujarati + //block.oriya + //block.tamil + //block.telugu + //block.kannada + //block.malayalam + //block.sinhala + //block.thai + //block.lao + //block.tibetan + //block.myanmar + //block.georgian)])) + + (def: character/1 + Set + (..set [//block.hangul_jamo + (list //block.ethiopic + //block.cherokee + //block.unified_canadian_aboriginal_syllabics + //block.ogham + //block.runic + //block.tagalog + //block.hanunoo + //block.buhid + //block.tagbanwa + //block.khmer + //block.mongolian + //block.limbu + //block.tai_le + //block.khmer_symbols + //block.phonetic_extensions + //block.latin_extended_additional + //block.greek_extended + //block.general_punctuation + //block.superscripts_and_subscripts + //block.currency_symbols + //block.combining_diacritical_marks_for_symbols + //block.letterlike_symbols + //block.number_forms + //block.arrows + //block.mathematical_operators + //block.miscellaneous_technical + //block.control_pictures + //block.optical_character_recognition + //block.enclosed_alphanumerics + //block.box_drawing)])) + + (def: character/2 + Set + (..set [//block.block_elements + (list //block.geometric_shapes + //block.miscellaneous_symbols + //block.dingbats + //block.miscellaneous_mathematical_symbols_a + //block.supplemental_arrows_a + //block.braille_patterns + //block.supplemental_arrows_b + //block.miscellaneous_mathematical_symbols_b + //block.supplemental_mathematical_operators + //block.miscellaneous_symbols_and_arrows + //block.cjk_radicals_supplement + //block.kangxi_radicals + //block.ideographic_description_characters + //block.cjk_symbols_and_punctuation + //block.hiragana + //block.katakana + //block.bopomofo + //block.hangul_compatibility_jamo + //block.kanbun + //block.bopomofo_extended + //block.katakana_phonetic_extensions + //block.enclosed_cjk_letters_and_months + //block.cjk_compatibility + //block.cjk_unified_ideographs_extension_a + //block.yijing_hexagram_symbols + //block.cjk_unified_ideographs + //block.yi_syllables + //block.yi_radicals + //block.hangul_syllables + )])) + + (def: #export character + Set + ($_ ..compose + ..character/0 + ..character/1 + ..character/2 + )) + + (def: #export non_character + Set + (..set [//block.high_surrogates + (list //block.high_private_use_surrogates + //block.low_surrogates + //block.private_use_area + //block.cjk_compatibility_ideographs + //block.alphabetic_presentation_forms + //block.arabic_presentation_forms_a + //block.variation_selectors + //block.combining_half_marks + //block.cjk_compatibility_forms + //block.small_form_variants + //block.arabic_presentation_forms_b + //block.halfwidth_and_fullwidth_forms + //block.specials + ## //block.linear_b_syllabary + ## //block.linear_b_ideograms + ## //block.aegean_numbers + ## //block.old_italic + ## //block.gothic + ## //block.ugaritic + ## //block.deseret + ## //block.shavian + ## //block.osmanya + ## //block.cypriot_syllabary + ## //block.byzantine_musical_symbols + ## //block.musical_symbols + ## //block.tai_xuan_jing_symbols + ## //block.mathematical_alphanumeric_symbols + ## //block.cjk_unified_ideographs_extension_b + ## //block.cjk_compatibility_ideographs_supplement + ## //block.tags + )])) + + (def: #export full + Set + ($_ ..compose + ..character + ..non_character + )) + + (def: #export (range set) + (-> Set [Char Char]) + (let [tag (tree.tag (:representation set))] + [(//block.start tag) + (//block.end tag)])) + + (def: #export (member? set character) + (-> Set Char Bit) + (loop [tree (:representation set)] + (if (//block.within? (tree.tag tree) character) + (case (tree.root tree) + (0 #0 _) + true + + (0 #1 left right) + (or (recur left) + (recur right))) + false))) + + (implementation: #export equivalence + (Equivalence Set) + + (def: (= reference subject) + (set\= (set.from_list //block.hash (tree.tags (:representation reference))) + (set.from_list //block.hash (tree.tags (:representation subject)))))) + ) + +(template [<name> <blocks>] + [(def: #export <name> + (..set <blocks>))] + + [ascii [//block.basic_latin (list)]] + [ascii/alpha [//block.basic_latin/upper (list //block.basic_latin/lower)]] + [ascii/alpha_num [//block.basic_latin/upper (list //block.basic_latin/lower //block.basic_latin/decimal)]] + [ascii/numeric [//block.basic_latin/decimal (list)]] + [ascii/upper [//block.basic_latin/upper (list)]] + [ascii/lower [//block.basic_latin/lower (list)]] + ) diff --git a/stdlib/source/library/lux/data/trace.lux b/stdlib/source/library/lux/data/trace.lux new file mode 100644 index 000000000..0edcff430 --- /dev/null +++ b/stdlib/source/library/lux/data/trace.lux @@ -0,0 +1,36 @@ +(.module: + [library + [lux #* + [abstract + ["." monoid (#+ Monoid)] + [functor (#+ Functor)] + comonad] + function]]) + +(type: #export (Trace t a) + {#monoid (Monoid t) + #trace (-> t a)}) + +(implementation: #export functor (All [t] (Functor (Trace t))) + (def: (map f fa) + (update@ #trace (compose f) fa))) + +(implementation: #export comonad (All [t] (CoMonad (Trace t))) + (def: &functor ..functor) + + (def: (unwrap wa) + ((get@ #trace wa) + (get@ [#monoid #monoid.identity] wa))) + + (def: (split wa) + (let [monoid (get@ #monoid wa)] + {#monoid monoid + #trace (function (_ t1) + {#monoid monoid + #trace (function (_ t2) + ((get@ #trace wa) + (\ monoid compose t1 t2)))})}))) + +(def: #export (run context tracer) + (All [t a] (-> t (Trace t a) a)) + (\ tracer trace context)) diff --git a/stdlib/source/library/lux/debug.lux b/stdlib/source/library/lux/debug.lux new file mode 100644 index 000000000..b73b92035 --- /dev/null +++ b/stdlib/source/library/lux/debug.lux @@ -0,0 +1,598 @@ +(.module: + [library + [lux (#- type) + ["@" target] + ["." type] + ["." ffi (#+ import:)] + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + [pipe (#+ new>)] + ["." function] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" type (#+ Parser)] + ["<.>" code]]] + [data + ["." text + ["%" format (#+ Format)]] + [format + [xml (#+ XML)] + ["." json]] + [collection + ["." array] + ["." list ("#\." functor)] + ["." dictionary]]] + [macro + ["." template] + ["." syntax (#+ syntax:)] + ["." code]] + [math + [number + [ratio (#+ Ratio)] + ["n" nat] + ["i" int]]] + [time (#+ Time) + [instant (#+ Instant)] + [duration (#+ Duration)] + [date (#+ Date)] + [month (#+ Month)] + [day (#+ Day)]]]]) + +(with_expansions [<jvm> (as_is (import: java/lang/String) + + (import: (java/lang/Class a) + ["#::." + (getCanonicalName [] java/lang/String)]) + + (import: java/lang/Object + ["#::." + (new []) + (toString [] java/lang/String) + (getClass [] (java/lang/Class java/lang/Object))]) + + (import: java/lang/Integer + ["#::." + (longValue [] long)]) + + (import: java/lang/Long + ["#::." + (intValue [] int)]) + + (import: java/lang/Number + ["#::." + (intValue [] int) + (longValue [] long) + (doubleValue [] double)]))] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>) + + @.js + (as_is (import: JSON + ["#::." + (#static stringify [.Any] ffi.String)]) + (import: Array + ["#::." + (#static isArray [.Any] ffi.Boolean)])) + + @.python + (as_is (type: PyType + (primitive "python_type")) + + (import: (type [.Any] PyType)) + (import: (str [.Any] ffi.String))) + + @.lua + (as_is (import: (type [.Any] ffi.String)) + (import: (tostring [.Any] ffi.String)) + + (import: math + ["#::." + (#static type [.Any] #? ffi.String)])) + + @.ruby + (as_is (import: Class) + + (import: Object + ["#::." + (class [] Class) + (to_s [] ffi.String)])) + + @.php + (as_is (import: (gettype [.Any] ffi.String)) + (import: (strval [.Any] ffi.String))) + + @.scheme + (as_is (import: (boolean? [.Any] Bit)) + (import: (integer? [.Any] Bit)) + (import: (real? [.Any] Bit)) + (import: (string? [.Any] Bit)) + (import: (vector? [.Any] Bit)) + (import: (pair? [.Any] Bit)) + (import: (car [.Any] .Any)) + (import: (cdr [.Any] .Any)) + (import: (format [Text .Any] Text))) + })) + +(def: Inspector + (.type (Format Any))) + +(for {@.lua (def: (tuple_array tuple) + (-> (array.Array Any) (array.Array Any)) + (array.from_list + (loop [idx 0] + (let [member ("lua array read" idx tuple)] + (if ("lua object nil?" member) + #.Nil + (#.Cons member (recur (inc idx))))))))} + (as_is)) + +(def: (inspect_tuple inspect) + (-> Inspector Inspector) + (with_expansions [<adaption> (for {@.lua (~~ (as_is ..tuple_array))} + (~~ (as_is)))] + (`` (|>> (:as (array.Array Any)) + <adaption> + array.to_list + (list\map inspect) + (text.join_with " ") + (text.enclose ["[" "]"]))))) + +(def: #export (inspect value) + Inspector + (with_expansions [<jvm> (let [object (:as java/lang/Object value)] + (`` (<| (~~ (template [<class> <processing>] + [(case (ffi.check <class> object) + (#.Some value) + (`` (|> value (~~ (template.splice <processing>)))) + #.None)] + + [java/lang/Boolean [(:as .Bit) %.bit]] + [java/lang/Long [(:as .Int) %.int]] + [java/lang/Number [java/lang/Number::doubleValue %.frac]] + [java/lang/String [(:as .Text) %.text]] + )) + (case (ffi.check [java/lang/Object] object) + (#.Some value) + (let [value (:as (array.Array java/lang/Object) value)] + (case (array.read 0 value) + (^multi (#.Some tag) + [(ffi.check java/lang/Integer tag) + (#.Some tag)] + [[(array.read 1 value) + (array.read 2 value)] + [last? + (#.Some choice)]]) + (let [last? (case last? + (#.Some _) #1 + #.None #0)] + (|> (%.format (%.nat (.nat (java/lang/Integer::longValue tag))) + " " (%.bit last?) + " " (inspect choice)) + (text.enclose ["(" ")"]))) + + _ + (inspect_tuple inspect value))) + #.None) + (java/lang/Object::toString object))))] + (for {@.old <jvm> + @.jvm <jvm> + + @.js + (case (ffi.type_of value) + (^template [<type_of> <then>] + [<type_of> + (`` (|> value (~~ (template.splice <then>))))]) + (["boolean" [(:as .Bit) %.bit]] + ["number" [(:as .Frac) %.frac]] + ["string" [(:as .Text) %.text]] + ["undefined" [JSON::stringify]]) + + "object" + (let [variant_tag ("js object get" "_lux_tag" value) + variant_flag ("js object get" "_lux_flag" value) + variant_value ("js object get" "_lux_value" value)] + (cond (not (or ("js object undefined?" variant_tag) + ("js object undefined?" variant_flag) + ("js object undefined?" variant_value))) + (|> (%.format (JSON::stringify variant_tag) + " " (%.bit (not ("js object null?" variant_flag))) + " " (inspect variant_value)) + (text.enclose ["(" ")"])) + + (not (or ("js object undefined?" ("js object get" "_lux_low" value)) + ("js object undefined?" ("js object get" "_lux_high" value)))) + (|> value (:as .Int) %.int) + + (Array::isArray value) + (inspect_tuple inspect value) + + ## else + (JSON::stringify value))) + + _ + (JSON::stringify value)) + + @.python + (case (..str (..type value)) + (^template [<type_of> <class_of> <then>] + [(^or <type_of> <class_of>) + (`` (|> value (~~ (template.splice <then>))))]) + (["<type 'bool'>" "<class 'bool'>" [(:as .Bit) %.bit]] + ["<type 'int'>" "<class 'int'>" [(:as .Int) %.int]] + ["<type 'float'>" "<class 'float'>" [(:as .Frac) %.frac]] + ["<type 'str'>" "<class 'str'>" [(:as .Text) %.text]] + ["<type 'unicode'>" "<class 'unicode'>" [(:as .Text) %.text]]) + + (^or "<type 'list'>" "<class 'list'>") + (inspect_tuple inspect value) + + (^or "<type 'tuple'>" "<type 'tuple'>") + (let [variant (:as (array.Array Any) value)] + (case (array.size variant) + 3 (let [variant_tag ("python array read" 0 variant) + variant_flag ("python array read" 1 variant) + variant_value ("python array read" 2 variant)] + (if (or ("python object none?" variant_tag) + ("python object none?" variant_value)) + (..str value) + (|> (%.format (|> variant_tag (:as .Nat) %.nat) + " " (|> variant_flag "python object none?" not %.bit) + " " (inspect variant_value)) + (text.enclose ["(" ")"])))) + _ (..str value))) + + _ + (..str value)) + + @.lua + (case (..type value) + (^template [<type_of> <then>] + [<type_of> + (`` (|> value (~~ (template.splice <then>))))]) + (["boolean" [(:as .Bit) %.bit]] + ["string" [(:as .Text) %.text]] + ["nil" [(new> "nil" [])]]) + + "number" + (case (math::type [value]) + (#.Some "integer") (|> value (:as .Int) %.int) + (#.Some "float") (|> value (:as .Frac) %.frac) + + _ + (..tostring value)) + + "table" + (let [variant_tag ("lua object get" "_lux_tag" value) + variant_flag ("lua object get" "_lux_flag" value) + variant_value ("lua object get" "_lux_value" value)] + (if (or ("lua object nil?" variant_tag) + ("lua object nil?" variant_value)) + (inspect_tuple inspect value) + (|> (%.format (|> variant_tag (:as .Nat) %.nat) + " " (%.bit (not ("lua object nil?" variant_flag))) + " " (inspect variant_value)) + (text.enclose ["(" ")"])))) + + _ + (..tostring value)) + + @.ruby + (template.let [(class_of <literal>) + [(|> <literal> + (:as ..Object) + (Object::class []))] + + (to_s <object>) + [(|> <object> + (:as ..Object) + (Object::to_s []))]] + (let [value_class (class_of value)] + (`` (cond (~~ (template [<literal> <type> <format>] + [(is? (class_of <literal>) value_class) + (|> value (:as <type>) <format>)] + + [#0 Bit %.bit] + [#1 Bit %.bit] + [+1 Int %.int] + [+1.0 Frac %.frac] + ["" Text %.text] + [("ruby object nil") Any (new> "nil" [])] + )) + + (is? (class_of #.None) value_class) + (let [variant_tag ("ruby object get" "_lux_tag" value) + variant_flag ("ruby object get" "_lux_flag" value) + variant_value ("ruby object get" "_lux_value" value)] + (if (or ("ruby object nil?" variant_tag) + ("ruby object nil?" variant_value)) + (inspect_tuple inspect value) + (|> (%.format (|> variant_tag (:as .Nat) %.nat) + " " (%.bit (not ("ruby object nil?" variant_flag))) + " " (inspect variant_value)) + (text.enclose ["(" ")"])))) + + (is? (class_of [[] []]) value_class) + (inspect_tuple inspect value) + + ## else + (to_s value))))) + + @.php + (case (..gettype value) + (^template [<type_of> <then>] + [<type_of> + (`` (|> value (~~ (template.splice <then>))))]) + (["boolean" [(:as .Bit) %.bit]] + ["integer" [(:as .Int) %.int]] + ["double" [(:as .Frac) %.frac]] + ["string" [(:as .Text) %.text]] + ["NULL" [(new> "null" [])]] + ["array" [(inspect_tuple inspect)]]) + + "object" + (let [variant_tag ("php object get" "_lux_tag" value) + variant_flag ("php object get" "_lux_flag" value) + variant_value ("php object get" "_lux_value" value)] + (if (or ("php object null?" variant_tag) + ("php object null?" variant_value)) + (..strval value) + (|> (%.format (|> variant_tag (:as .Nat) %.nat) + " " (%.bit (not ("php object null?" variant_flag))) + " " (inspect variant_value)) + (text.enclose ["(" ")"])))) + + _ + (..strval value)) + + @.scheme + (`` (cond (~~ (template [<when> <then>] + [(<when> value) + (`` (|> value (~~ (template.splice <then>))))] + + [..boolean? [(:as .Bit) %.bit]] + [..integer? [(:as .Int) %.int]] + [..real? [(:as .Frac) %.frac]] + [..string? [(:as .Text) %.text]] + ["scheme object nil?" [(new> "()" [])]] + [..vector? [(inspect_tuple inspect)]])) + + (..pair? value) + (let [variant_tag (..car value) + variant_rest (..cdr value)] + (if (and (..integer? variant_tag) + (i.> +0 (:as Int variant_tag)) + (..pair? variant_rest)) + (let [variant_flag (..car variant_rest) + variant_value (..cdr variant_rest)] + (|> (%.format (|> variant_tag (:as .Nat) %.nat) + " " (%.bit (not ("scheme object nil?" variant_flag))) + " " (inspect variant_value)) + (text.enclose ["(" ")"]))) + (..format ["~s" value]))) + + ## else + (..format ["~s" value]) + )) + }))) + +(exception: #export (cannot_represent_value {type Type}) + (exception.report + ["Type" (%.type type)])) + +(type: Representation + (-> Any Text)) + +(def: primitive_representation + (Parser Representation) + (`` ($_ <>.either + (do <>.monad + [_ (<type>.exactly Any)] + (wrap (function.constant "[]"))) + + (~~ (template [<type> <formatter>] + [(do <>.monad + [_ (<type>.sub <type>)] + (wrap (|>> (:as <type>) <formatter>)))] + + [Bit %.bit] + [Nat %.nat] + [Int %.int] + [Rev %.rev] + [Frac %.frac] + [Text %.text])) + ))) + +(def: (special_representation representation) + (-> (Parser Representation) (Parser Representation)) + (`` ($_ <>.either + (~~ (template [<type> <formatter>] + [(do <>.monad + [_ (<type>.sub <type>)] + (wrap (|>> (:as <type>) <formatter>)))] + + [Ratio %.ratio] + [Name %.name] + [Location %.location] + [Type %.type] + [Code %.code] + + [Instant %.instant] + [Duration %.duration] + [Date %.date] + [Time %.time] + [Month %.month] + [Day %.day] + + [json.JSON %.json] + [XML %.xml])) + + (do <>.monad + [[_ elemT] (<type>.apply (<>.and (<type>.exactly List) <type>.any)) + elemR (<type>.local (list elemT) representation)] + (wrap (|>> (:as (List Any)) (%.list elemR)))) + + (do <>.monad + [[_ elemT] (<type>.apply (<>.and (<type>.exactly Maybe) <type>.any)) + elemR (<type>.local (list elemT) representation)] + (wrap (|>> (:as (Maybe Any)) + (%.maybe elemR))))))) + +(def: (variant_representation representation) + (-> (Parser Representation) (Parser Representation)) + (do <>.monad + [membersR+ (<type>.variant (<>.many representation))] + (wrap (function (_ variantV) + (let [[lefts right? sub_repr] (loop [lefts 0 + representations membersR+ + variantV variantV] + (case representations + (#.Cons leftR (#.Cons rightR extraR+)) + (case (:as (| Any Any) variantV) + (#.Left left) + [lefts #0 (leftR left)] + + (#.Right right) + (case extraR+ + #.Nil + [lefts #1 (rightR right)] + + _ + (recur (inc lefts) (#.Cons rightR extraR+) right))) + + _ + (undefined)))] + (%.format "(" (%.nat lefts) " " (%.bit right?) " " sub_repr ")")))))) + +(def: (tuple_representation representation) + (-> (Parser Representation) (Parser Representation)) + (do <>.monad + [membersR+ (<type>.tuple (<>.many representation))] + (wrap (function (_ tupleV) + (let [tuple_body (loop [representations membersR+ + tupleV tupleV] + (case representations + #.Nil + "" + + (#.Cons lastR #.Nil) + (lastR tupleV) + + (#.Cons headR tailR) + (let [[leftV rightV] (:as [Any Any] tupleV)] + (%.format (headR leftV) " " (recur tailR rightV)))))] + (%.format "[" tuple_body "]")))))) + +(def: representation + (Parser Representation) + (<>.rec + (function (_ representation) + ($_ <>.either + ..primitive_representation + (..special_representation representation) + (..variant_representation representation) + (..tuple_representation representation) + + (do <>.monad + [[funcT inputsT+] (<type>.apply (<>.and <type>.any (<>.many <type>.any)))] + (case (type.apply inputsT+ funcT) + (#.Some outputT) + (<type>.local (list outputT) representation) + + #.None + (<>.fail ""))) + + (do <>.monad + [[name anonymous] <type>.named] + (<type>.local (list anonymous) representation)) + + (<>.fail "") + )))) + +(def: #export (represent type value) + (-> Type Any (Try Text)) + (case (<type>.run ..representation type) + (#try.Success representation) + (#try.Success (representation value)) + + (#try.Failure _) + (exception.throw ..cannot_represent_value type))) + +(syntax: #export (private {definition <code>.identifier}) + (let [[module _] definition] + (wrap (list (` ("lux in-module" + (~ (code.text module)) + (~ (code.identifier definition)))))))) + +(def: #export (log! message) + {#.doc "Logs message to standard output."} + (-> Text Any) + ("lux io log" message)) + +(exception: #export (type_hole {location Location} {type Type}) + (exception.report + ["Location" (%.location location)] + ["Type" (%.type type)])) + +(syntax: #export (:hole) + (do meta.monad + [location meta.location + expectedT meta.expected_type] + (function.constant (exception.throw ..type_hole [location expectedT])))) + +(type: Target + [Text (Maybe Code)]) + +(def: target + (<code>.Parser Target) + (<>.either (<>.and <code>.local_identifier + (\ <>.monad wrap #.None)) + (<code>.record (<>.and <code>.local_identifier + (\ <>.monad map (|>> #.Some) <code>.any))))) + +(exception: #export (unknown_local_binding {name Text}) + (exception.report + ["Name" (%.text name)])) + +(syntax: #export (here {targets (: (<code>.Parser (List Target)) + (|> ..target + <>.some + (<>.default (list))))}) + (do {! meta.monad} + [location meta.location + locals meta.locals + #let [environment (|> locals + list.concat + ## The list is reversed to make sure that, when building the dictionary, + ## later bindings overshadow earlier ones if they have the same name. + list.reverse + (dictionary.from_list text.hash))] + targets (: (Meta (List Target)) + (case targets + #.Nil + (|> environment + dictionary.keys + (list\map (function (_ local) [local #.None])) + wrap) + + _ + (monad.map ! (function (_ [name format]) + (if (dictionary.key? environment name) + (wrap [name format]) + (function.constant (exception.throw ..unknown_local_binding [name])))) + targets)))] + (wrap (list (` (..log! ("lux text concat" + (~ (code.text (%.format (%.location location) text.new_line))) + ((~! exception.report) + (~+ (list\map (function (_ [name format]) + (let [format (case format + #.None + (` (~! ..inspect)) + + (#.Some format) + format)] + (` [(~ (code.text name)) + ((~ format) (~ (code.local_identifier name)))]))) + targets)))))))))) diff --git a/stdlib/source/library/lux/extension.lux b/stdlib/source/library/lux/extension.lux new file mode 100644 index 000000000..5cad0158c --- /dev/null +++ b/stdlib/source/library/lux/extension.lux @@ -0,0 +1,89 @@ +(.module: + [library + [lux #* + [abstract + ["." monad]] + [control + ["<>" parser ("#\." monad) + ["<c>" code (#+ Parser)] + ["<a>" analysis] + ["<s>" synthesis]]] + [data + ["." product] + [collection + ["." list ("#\." functor)]]] + [macro (#+ with_gensyms) + ["." code] + [syntax (#+ syntax:)]] + [tool + [compiler + ["." phase]]]]]) + +(type: Input + {#variable Text + #parser Code}) + +(def: (simple default) + (-> Code (Parser Input)) + ($_ <>.and + <c>.local_identifier + (<>\wrap default))) + +(def: complex + (Parser Input) + (<c>.record ($_ <>.and + <c>.local_identifier + <c>.any))) + +(def: (input default) + (-> Code (Parser Input)) + (<>.either (..simple default) + ..complex)) + +(type: Declaration + {#name Code + #label Text + #phase Text + #archive Text + #inputs (List Input)}) + +(def: (declaration default) + (-> Code (Parser Declaration)) + (<c>.form ($_ <>.and + <c>.any + <c>.local_identifier + <c>.local_identifier + <c>.local_identifier + (<>.some (..input default))))) + +(template [<any> <end> <and> <run> <extension> <name>] + [(syntax: #export (<name> + {[name extension phase archive inputs] (..declaration (` <any>))} + body) + (let [g!parser (case (list\map product.right inputs) + #.Nil + (` <end>) + + parsers + (` (.$_ <and> (~+ parsers)))) + g!name (code.local_identifier extension) + g!phase (code.local_identifier phase) + g!archive (code.local_identifier archive)] + (with_gensyms [g!handler g!inputs g!error] + (wrap (list (` (<extension> (~ name) + (.function ((~ g!handler) (~ g!name) (~ g!phase) (~ g!archive) (~ g!inputs)) + (.case ((~! <run>) (~ g!parser) (~ g!inputs)) + (#.Right [(~+ (list\map (|>> product.left + code.local_identifier) + inputs))]) + (~ body) + + (#.Left (~ g!error)) + ((~! phase.fail) (~ g!error))) + ))))))))] + + [<c>.any <c>.end! <c>.and <c>.run "lux def analysis" analysis:] + [<a>.any <a>.end! <a>.and <a>.run "lux def synthesis" synthesis:] + [<s>.any <s>.end! <s>.and <s>.run "lux def generation" generation:] + [<c>.any <c>.end! <c>.and <c>.run "lux def directive" directive:] + ) diff --git a/stdlib/source/library/lux/ffi.js.lux b/stdlib/source/library/lux/ffi.js.lux new file mode 100644 index 000000000..aae11fc1d --- /dev/null +++ b/stdlib/source/library/lux/ffi.js.lux @@ -0,0 +1,364 @@ +(.module: + [library + [lux #* + ["." meta] + [abstract + [monad (#+ do)]] + [control + ["." io] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text + ["%" format]] + [collection + ["." list ("#\." functor fold)]]] + [type + abstract] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code] + ["." template]]]]) + +(abstract: #export (Object brand) + Any) + +(template [<name>] + [(with_expansions [<brand> (template.identifier [<name> "'"])] + (abstract: <brand> + Any + + (type: #export <name> + (Object <brand>))))] + + [Function] + [Symbol] + [Null] + [Undefined] + ) + +(template [<name> <type>] + [(type: #export <name> + <type>)] + + [Boolean Bit] + [Number Frac] + [String Text] + ) + +(type: Nullable + [Bit Code]) + +(def: nullable + (Parser Nullable) + (let [token (' #?)] + (<| (<>.and (<>.parses? (<code>.this! token))) + (<>.after (<>.not (<code>.this! token))) + <code>.any))) + +(type: Constructor + (List Nullable)) + +(def: constructor + (Parser Constructor) + (<code>.form (<>.after (<code>.this! (' new)) + (<code>.tuple (<>.some ..nullable))))) + +(type: Field + [Bit Text Nullable]) + +(def: static! + (Parser Any) + (<code>.this! (' #static))) + +(def: field + (Parser Field) + (<code>.form ($_ <>.and + (<>.parses? ..static!) + <code>.local_identifier + ..nullable))) + +(type: Common_Method + {#name Text + #alias (Maybe Text) + #inputs (List Nullable) + #io? Bit + #try? Bit + #output Nullable}) + +(type: Static_Method Common_Method) +(type: Virtual_Method Common_Method) + +(type: Method + (#Static Static_Method) + (#Virtual Virtual_Method)) + +(def: common_method + (Parser Common_Method) + ($_ <>.and + <code>.local_identifier + (<>.maybe (<>.after (<code>.this! (' #as)) <code>.local_identifier)) + (<code>.tuple (<>.some ..nullable)) + (<>.parses? (<code>.this! (' #io))) + (<>.parses? (<code>.this! (' #try))) + ..nullable)) + +(def: static_method + (<>.after ..static! ..common_method)) + +(def: method + (Parser Method) + (<code>.form (<>.or ..static_method + ..common_method))) + +(type: Member + (#Constructor Constructor) + (#Field Field) + (#Method Method)) + +(def: member + (Parser Member) + ($_ <>.or + ..constructor + ..field + ..method + )) + +(def: input_variables + (-> (List Nullable) (List [Bit Code])) + (|>> list.enumeration + (list\map (function (_ [idx [nullable? type]]) + [nullable? (|> idx %.nat code.local_identifier)])))) + +(def: (nullable_type [nullable? type]) + (-> Nullable Code) + (if nullable? + (` (.Maybe (~ type))) + type)) + +(def: (with_null g!temp [nullable? input]) + (-> Code [Bit Code] Code) + (if nullable? + (` (case (~ input) + (#.Some (~ g!temp)) + (~ g!temp) + + #.None + ("js object null"))) + input)) + +(def: (without_null g!temp [nullable? outputT] output) + (-> Code Nullable Code Code) + (if nullable? + (` (let [(~ g!temp) (~ output)] + (if ("js object null?" (~ g!temp)) + #.None + (#.Some (~ g!temp))))) + (` (let [(~ g!temp) (~ output)] + (if (not ("js object null?" (~ g!temp))) + (~ g!temp) + (.error! "Null is an invalid value.")))))) + +(type: Import + (#Class [Text Text (List Member)]) + (#Function Static_Method)) + +(def: import + (Parser Import) + (<>.or (<>.and <code>.local_identifier + (<>.default ["" (list)] + (<code>.tuple (<>.and <code>.text + (<>.some member))))) + (<code>.form ..common_method))) + +(def: (with_io with? without) + (-> Bit Code Code) + (if with? + (` (io.io (~ without))) + without)) + +(def: (io_type io? rawT) + (-> Bit Code Code) + (if io? + (` (io.IO (~ rawT))) + rawT)) + +(def: (with_try with? without_try) + (-> Bit Code Code) + (if with? + (` (.try (~ without_try))) + without_try)) + +(def: (try_type try? rawT) + (-> Bit Code Code) + (if try? + (` (.Either .Text (~ rawT))) + rawT)) + +(def: (make_function g!method g!temp source inputsT io? try? outputT) + (-> Code Code Text (List Nullable) Bit Bit Nullable Code) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ g!method) + [(~+ (list\map product.right g!inputs))]) + (-> [(~+ (list\map nullable_type inputsT))] + (~ (|> (nullable_type outputT) + (try_type try?) + (io_type io?)))) + (:assume + (~ (<| (with_io io?) + (with_try try?) + (without_null g!temp outputT) + (` ("js apply" + ("js constant" (~ (code.text source))) + (~+ (list\map (with_null g!temp) g!inputs))))))))))) + +(syntax: #export (import: {import ..import}) + (with_gensyms [g!temp] + (case import + (#Class [class format members]) + (with_gensyms [g!object] + (let [qualify (: (-> Text Code) + (function (_ member_name) + (|> format + (text.replace_all "#" class) + (text.replace_all "." member_name) + code.local_identifier))) + g!type (code.local_identifier class) + real_class (text.replace_all "/" "." class)] + (wrap (list& (` (type: (~ g!type) + (..Object (primitive (~ (code.text real_class)))))) + (list\map (function (_ member) + (case member + (#Constructor inputsT) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ (qualify "new")) + [(~+ (list\map product.right g!inputs))]) + (-> [(~+ (list\map nullable_type inputsT))] + (~ g!type)) + (:assume + ("js object new" + ("js constant" (~ (code.text real_class))) + [(~+ (list\map (with_null g!temp) g!inputs))]))))) + + (#Field [static? field fieldT]) + (if static? + (` ((~! syntax:) ((~ (qualify field))) + (\ (~! meta.monad) (~' wrap) + (list (` (.:as (~ (nullable_type fieldT)) + ("js constant" (~ (code.text (%.format real_class "." field)))))))))) + (` (def: ((~ (qualify field)) + (~ g!object)) + (-> (~ g!type) + (~ (nullable_type fieldT))) + (:assume + (~ (without_null g!temp fieldT (` ("js object get" (~ (code.text field)) (~ g!object))))))))) + + (#Method method) + (case method + (#Static [method alias inputsT io? try? outputT]) + (..make_function (qualify (maybe.default method alias)) + g!temp + (%.format real_class "." method) + inputsT + io? + try? + outputT) + + (#Virtual [method alias inputsT io? try? outputT]) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ (qualify (maybe.default method alias))) + [(~+ (list\map product.right g!inputs))] + (~ g!object)) + (-> [(~+ (list\map nullable_type inputsT))] + (~ g!type) + (~ (|> (nullable_type outputT) + (try_type try?) + (io_type io?)))) + (:assume + (~ (<| (with_io io?) + (with_try try?) + (without_null g!temp outputT) + (` ("js object do" + (~ (code.text method)) + (~ g!object) + [(~+ (list\map (with_null g!temp) g!inputs))]))))))))))) + members))))) + + (#Function [name alias inputsT io? try? outputT]) + (wrap (list (..make_function (code.local_identifier (maybe.default name alias)) + g!temp + name + inputsT + io? + try? + outputT))) + ))) + +(template: #export (type_of object) + ("js type-of" object)) + +(syntax: #export (constant type + {[head tail] (<code>.tuple (<>.and <code>.local_identifier (<>.some <code>.local_identifier)))}) + (with_gensyms [g!_] + (let [constant (` ("js constant" (~ (code.text head))))] + (case tail + #.Nil + (wrap (list (` (: (.Maybe (~ type)) + (case (..type_of (~ constant)) + "undefined" + #.None + + (~ g!_) + (#.Some (:as (~ type) (~ constant)))))))) + + (#.Cons [next tail]) + (let [separator "."] + (wrap (list (` (: (.Maybe (~ type)) + (case (..type_of (~ constant)) + "undefined" + #.None + + (~ g!_) + (..constant (~ type) [(~ (code.local_identifier (%.format head "." next))) + (~+ (list\map code.local_identifier tail))]))))))))))) + +(template: (!defined? <constant>) + (.case (..constant Any <constant>) + #.None + .false + + (#.Some _) + .true)) + +(template [<name> <constant>] + [(def: #export <name> + Bit + (!defined? <constant>))] + + [on_browser? [window]] + [on_nashorn? [java lang Object]] + ) + +(def: #export on_node_js? + Bit + (case (..constant (Object Any) [process]) + (#.Some process) + (case (:as Text + ("js apply" ("js constant" "Object.prototype.toString.call") process)) + "[object process]" + true + + _ + false) + + #.None + false)) + +(template: #export (closure <inputs> <output>) + (.:as ..Function + (`` ("js function" + (~~ (template.count <inputs>)) + (.function (_ [<inputs>]) + <output>))))) diff --git a/stdlib/source/library/lux/ffi.jvm.lux b/stdlib/source/library/lux/ffi.jvm.lux new file mode 100644 index 000000000..881c3f79d --- /dev/null +++ b/stdlib/source/library/lux/ffi.jvm.lux @@ -0,0 +1,2048 @@ +(.module: + [library + ["." lux (#- Type type int char interface:) + ["#_." type ("#\." equivalence)] + [abstract + ["." monad (#+ Monad do)] + ["." enum]] + [control + ["." function] + ["." io] + ["." try (#+ Try)] + ["." exception (#+ Exception exception:)] + ["<>" parser ("#\." monad) + ["<.>" code (#+ Parser)]]] + [data + ["." maybe] + ["." product] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." array] + ["." list ("#\." monad fold monoid)] + ["." dictionary (#+ Dictionary)]]] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code] + ["." template]] + ["." meta + ["." annotation]] + [target + [jvm + [encoding + ["." name (#+ External)]] + ["." type (#+ Type Argument Typed) + ["." category (#+ Void Value' Value Return' Return Method Primitive Object Class Array Var Parameter Declaration)] + ["." box] + ["." descriptor] + ["." signature] + ["." reflection] + ["." parser]]]]]]) + +(def: internal + (-> External Text) + (|>> name.internal + name.read)) + +(def: signature + (All [category] + (-> (Type category) Text)) + (|>> type.signature signature.signature)) + +(def: reflection + (All [category] + (-> (Type (<| Return' Value' category)) Text)) + (|>> type.reflection reflection.reflection)) + +(template [<name> <class>] + [(def: #export <name> + .Type + (#.Primitive <class> #.Nil))] + + [Boolean box.boolean] + [Byte box.byte] + [Short box.short] + [Integer box.int] + [Long box.long] + [Float box.float] + [Double box.double] + [Character box.char] + ) + +(template [<name> <class>] + [(def: #export <name> + .Type + (#.Primitive (reflection.reflection <class>) #.Nil))] + + ## Primitives + [boolean reflection.boolean] + [byte reflection.byte] + [short reflection.short] + [int reflection.int] + [long reflection.long] + [float reflection.float] + [double reflection.double] + [char reflection.char] + ) + +(def: (get_static_field class field) + (-> Text Text Code) + (` ("jvm member get static" + (~ (code.text class)) + (~ (code.text field))))) + +(def: (get_virtual_field class field object) + (-> Text Text Code Code) + (` ("jvm member get virtual" + (~ (code.text class)) + (~ (code.text field)) + (~ object)))) + +(def: boxes + (Dictionary (Type Value) Text) + (|> (list [type.boolean box.boolean] + [type.byte box.byte] + [type.short box.short] + [type.int box.int] + [type.long box.long] + [type.float box.float] + [type.double box.double] + [type.char box.char]) + (dictionary.from_list type.hash))) + +(template [<name> <pre> <post>] + [(def: (<name> unboxed boxed raw) + (-> (Type Value) Text Code Code) + (let [unboxed (..reflection unboxed)] + (` (|> (~ raw) + (: (primitive (~ (code.text <pre>)))) + "jvm object cast" + (: (primitive (~ (code.text <post>))))))))] + + [unbox boxed unboxed] + [box unboxed boxed] + ) + +(template [<name> <op> <from> <to>] + [(template: #export (<name> value) + {#.doc (doc "Type converter." + (: <to> + (<name> (: <from> foo))))} + (|> value + (: <from>) + "jvm object cast" + <op> + "jvm object cast" + (: <to>)))] + + [byte_to_long "jvm conversion byte-to-long" ..Byte ..Long] + + [short_to_long "jvm conversion short-to-long" ..Short ..Long] + + [double_to_int "jvm conversion double-to-int" ..Double ..Integer] + [double_to_long "jvm conversion double-to-long" ..Double ..Long] + [double_to_float "jvm conversion double-to-float" ..Double ..Float] + + [float_to_int "jvm conversion float-to-int" ..Float ..Integer] + [float_to_long "jvm conversion float-to-long" ..Float ..Long] + [float_to_double "jvm conversion float-to-double" ..Float ..Double] + + [int_to_byte "jvm conversion int-to-byte" ..Integer ..Byte] + [int_to_short "jvm conversion int-to-short" ..Integer ..Short] + [int_to_long "jvm conversion int-to-long" ..Integer ..Long] + [int_to_float "jvm conversion int-to-float" ..Integer ..Float] + [int_to_double "jvm conversion int-to-double" ..Integer ..Double] + [int_to_char "jvm conversion int-to-char" ..Integer ..Character] + + [long_to_byte "jvm conversion long-to-byte" ..Long ..Byte] + [long_to_short "jvm conversion long-to-short" ..Long ..Short] + [long_to_int "jvm conversion long-to-int" ..Long ..Integer] + [long_to_float "jvm conversion long-to-float" ..Long ..Float] + [long_to_double "jvm conversion long-to-double" ..Long ..Double] + + [char_to_byte "jvm conversion char-to-byte" ..Character ..Byte] + [char_to_short "jvm conversion char-to-short" ..Character ..Short] + [char_to_int "jvm conversion char-to-int" ..Character ..Integer] + [char_to_long "jvm conversion char-to-long" ..Character ..Long] + ) + +(template [<name> <from> <to> <0> <1>] + [(template: #export (<name> value) + {#.doc (doc "Type converter." + (: <to> + (<name> (: <from> foo))))} + (|> value <0> <1>))] + + [long_to_char ..Long ..Character ..long_to_int ..int_to_char] + [byte_to_int ..Byte ..Integer ..byte_to_long ..long_to_int] + [short_to_int ..Short ..Integer ..short_to_long ..long_to_int] + [byte_to_char ..Byte ..Character ..byte_to_int ..int_to_char] + [short_to_char ..Short ..Character ..short_to_int ..int_to_char] + ) + +(def: constructor_method_name + "<init>") + +(type: Primitive_Mode + #ManualPrM + #AutoPrM) + +(type: Privacy + #PublicP + #PrivateP + #ProtectedP + #DefaultP) + +(type: StateModifier + #VolatileSM + #FinalSM + #DefaultSM) + +(type: InheritanceModifier + #FinalIM + #AbstractIM + #DefaultIM) + +(type: Class_Kind + #Class + #Interface) + +(type: StackFrame (primitive "java/lang/StackTraceElement")) +(type: StackTrace (array.Array StackFrame)) + +(type: Annotation_Parameter + [Text Code]) + +(type: Annotation + {#ann_name Text + #ann_params (List Annotation_Parameter)}) + +(type: Member_Declaration + {#member_name Text + #member_privacy Privacy + #member_anns (List Annotation)}) + +(type: FieldDecl + (#ConstantField (Type Value) Code) + (#VariableField StateModifier (Type Value))) + +(type: MethodDecl + {#method_tvars (List (Type Var)) + #method_inputs (List (Type Value)) + #method_output (Type Return) + #method_exs (List (Type Class))}) + +(type: Method_Definition + (#ConstructorMethod [Bit + (List (Type Var)) + Text + (List Argument) + (List (Typed Code)) + Code + (List (Type Class))]) + (#VirtualMethod [Bit + Bit + (List (Type Var)) + Text + (List Argument) + (Type Return) + Code + (List (Type Class))]) + (#OverridenMethod [Bit + (Type Declaration) + (List (Type Var)) + Text + (List Argument) + (Type Return) + Code + (List (Type Class))]) + (#StaticMethod [Bit + (List (Type Var)) + (List Argument) + (Type Return) + Code + (List (Type Class))]) + (#AbstractMethod [(List (Type Var)) + (List Argument) + (Type Return) + (List (Type Class))]) + (#NativeMethod [(List (Type Var)) + (List Argument) + (Type Return) + (List (Type Class))])) + +(type: Partial_Call + {#pc_method Name + #pc_args (List Code)}) + +(type: ImportMethodKind + #StaticIMK + #VirtualIMK) + +(type: ImportMethodCommons + {#import_member_mode Primitive_Mode + #import_member_alias Text + #import_member_kind ImportMethodKind + #import_member_tvars (List (Type Var)) + #import_member_args (List [Bit (Type Value)]) + #import_member_maybe? Bit + #import_member_try? Bit + #import_member_io? Bit}) + +(type: ImportConstructorDecl + {}) + +(type: ImportMethodDecl + {#import_method_name Text + #import_method_return (Type Return)}) + +(type: ImportFieldDecl + {#import_field_mode Primitive_Mode + #import_field_name Text + #import_field_static? Bit + #import_field_maybe? Bit + #import_field_setter? Bit + #import_field_type (Type Value)}) + +(type: Import_Member_Declaration + (#EnumDecl (List Text)) + (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]) + (#MethodDecl [ImportMethodCommons ImportMethodDecl]) + (#FieldAccessDecl ImportFieldDecl)) + +(def: (primitive_type mode type) + (-> Primitive_Mode (Type Primitive) Code) + (case mode + #ManualPrM + (cond (\ type.equivalence = type.boolean type) (` ..Boolean) + (\ type.equivalence = type.byte type) (` ..Byte) + (\ type.equivalence = type.short type) (` ..Short) + (\ type.equivalence = type.int type) (` ..Integer) + (\ type.equivalence = type.long type) (` ..Long) + (\ type.equivalence = type.float type) (` ..Float) + (\ type.equivalence = type.double type) (` ..Double) + (\ type.equivalence = type.char type) (` ..Character) + ## else + (undefined)) + + #AutoPrM + (cond (\ type.equivalence = type.boolean type) + (` .Bit) + + (or (\ type.equivalence = type.short type) + (\ type.equivalence = type.byte type) + (\ type.equivalence = type.int type) + (\ type.equivalence = type.long type)) + (` .Int) + + (or (\ type.equivalence = type.float type) + (\ type.equivalence = type.double type)) + (` .Frac) + + (\ type.equivalence = type.char type) + (` .Nat) + + ## else + (undefined)))) + +(def: (parameter_type type) + (-> (Type Parameter) Code) + (`` (<| (~~ (template [<when> <binding> <then>] + [(case (<when> type) + (#.Some <binding>) + <then> + + #.None)] + + [parser.var? name (code.identifier ["" name])] + [parser.wildcard? _ (` .Any)] + [parser.lower? _ (` .Any)] + [parser.upper? limit (parameter_type limit)] + [parser.class? [name parameters] + (` (.primitive (~ (code.text name)) + [(~+ (list\map parameter_type parameters))]))])) + ## else + (undefined) + ))) + +(def: (value_type mode type) + (-> Primitive_Mode (Type Value) Code) + (`` (<| (~~ (template [<when> <binding> <then>] + [(case (<when> type) + (#.Some <binding>) + <then> + + #.None)] + + [parser.parameter? type (parameter_type type)] + [parser.primitive? type (primitive_type mode type)] + [parser.array? elementT (case (parser.primitive? elementT) + (#.Some elementT) + (` (#.Primitive (~ (code.text (..reflection (type.array elementT)))) #.Nil)) + + #.None + (` (#.Primitive (~ (code.text array.type_name)) + (#.Cons (~ (value_type mode elementT)) #.Nil))))])) + (undefined) + ))) + +(def: declaration_type$ + (-> (Type Declaration) Code) + (|>> ..signature code.text)) + +(def: (make_get_const_parser class_name field_name) + (-> Text Text (Parser Code)) + (do <>.monad + [#let [dotted_name (format "::" field_name)] + _ (<code>.this! (code.identifier ["" dotted_name]))] + (wrap (get_static_field class_name field_name)))) + +(def: (make_get_var_parser class_name field_name) + (-> Text Text (Parser Code)) + (do <>.monad + [#let [dotted_name (format "::" field_name)] + _ (<code>.this! (code.identifier ["" dotted_name]))] + (wrap (get_virtual_field class_name field_name (' _jvm_this))))) + +(def: (make_put_var_parser class_name field_name) + (-> Text Text (Parser Code)) + (do <>.monad + [#let [dotted_name (format "::" field_name)] + [_ _ value] (: (Parser [Any Any Code]) + (<code>.form ($_ <>.and (<code>.this! (' :=)) (<code>.this! (code.identifier ["" dotted_name])) <code>.any)))] + (wrap (`' ((~ (code.text (format "jvm putfield" ":" class_name ":" field_name))) _jvm_this (~ value)))))) + +(def: (pre_walk_replace f input) + (-> (-> Code Code) Code Code) + (case (f input) + (^template [<tag>] + [[meta (<tag> parts)] + [meta (<tag> (list\map (pre_walk_replace f) parts))]]) + ([#.Form] + [#.Tuple]) + + [meta (#.Record pairs)] + [meta (#.Record (list\map (: (-> [Code Code] [Code Code]) + (function (_ [key val]) + [(pre_walk_replace f key) (pre_walk_replace f val)])) + pairs))] + + ast' + ast')) + +(def: (parser->replacer p ast) + (-> (Parser Code) (-> Code Code)) + (case (<>.run p (list ast)) + (#.Right [#.Nil ast']) + ast' + + _ + ast + )) + +(def: (field->parser class_name [[field_name _ _] field]) + (-> Text [Member_Declaration FieldDecl] (Parser Code)) + (case field + (#ConstantField _) + (make_get_const_parser class_name field_name) + + (#VariableField _) + (<>.either (make_get_var_parser class_name field_name) + (make_put_var_parser class_name field_name)))) + +(def: (decorate_input [class value]) + (-> [(Type Value) Code] Code) + (` [(~ (code.text (..signature class))) (~ value)])) + +(def: (make_constructor_parser class_name arguments) + (-> Text (List Argument) (Parser Code)) + (do <>.monad + [args (: (Parser (List Code)) + (<code>.form (<>.after (<code>.this! (' ::new!)) + (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))] + (wrap (` ("jvm member invoke constructor" (~ (code.text class_name)) + (~+ (|> args + (list.zip/2 (list\map product.right arguments)) + (list\map ..decorate_input)))))))) + +(def: (make_static_method_parser class_name method_name arguments) + (-> Text Text (List Argument) (Parser Code)) + (do <>.monad + [#let [dotted_name (format "::" method_name "!")] + args (: (Parser (List Code)) + (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name])) + (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))] + (wrap (` ("jvm member invoke static" (~ (code.text class_name)) (~ (code.text method_name)) + (~+ (|> args + (list.zip/2 (list\map product.right arguments)) + (list\map ..decorate_input)))))))) + +(template [<name> <jvm_op>] + [(def: (<name> class_name method_name arguments) + (-> Text Text (List Argument) (Parser Code)) + (do <>.monad + [#let [dotted_name (format "::" method_name "!")] + args (: (Parser (List Code)) + (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name])) + (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))] + (wrap (` (<jvm_op> (~ (code.text class_name)) (~ (code.text method_name)) + (~' _jvm_this) + (~+ (|> args + (list.zip/2 (list\map product.right arguments)) + (list\map ..decorate_input))))))))] + + [make_special_method_parser "jvm member invoke special"] + [make_virtual_method_parser "jvm member invoke virtual"] + ) + +(def: (method->parser class_name [[method_name _ _] meth_def]) + (-> Text [Member_Declaration Method_Definition] (Parser Code)) + (case meth_def + (#ConstructorMethod strict? type_vars self_name args constructor_args return_expr exs) + (make_constructor_parser class_name args) + + (#StaticMethod strict? type_vars args return_type return_expr exs) + (make_static_method_parser class_name method_name args) + + (^or (#VirtualMethod final? strict? type_vars self_name args return_type return_expr exs) + (#OverridenMethod strict? owner_class type_vars self_name args return_type return_expr exs)) + (make_special_method_parser class_name method_name args) + + (#AbstractMethod type_vars args return_type exs) + (make_virtual_method_parser class_name method_name args) + + (#NativeMethod type_vars args return_type exs) + (make_virtual_method_parser class_name method_name args))) + +(def: privacy_modifier^ + (Parser Privacy) + (let [(^open ".") <>.monad] + ($_ <>.or + (<code>.this! (' #public)) + (<code>.this! (' #private)) + (<code>.this! (' #protected)) + (wrap [])))) + +(def: inheritance_modifier^ + (Parser InheritanceModifier) + (let [(^open ".") <>.monad] + ($_ <>.or + (<code>.this! (' #final)) + (<code>.this! (' #abstract)) + (wrap [])))) + +(exception: #export (class_names_cannot_contain_periods {name Text}) + (exception.report + ["Name" (%.text name)])) + +(exception: #export (class_name_cannot_be_a_type_variable {name Text} + {type_vars (List (Type Var))}) + (exception.report + ["Name" (%.text name)] + ["Type Variables" (exception.enumerate parser.name type_vars)])) + +(def: (assert exception payload test) + (All [e] (-> (Exception e) e Bit (Parser Any))) + (<>.assert (exception.construct exception payload) + test)) + +(def: (valid_class_name type_vars) + (-> (List (Type Var)) (Parser External)) + (do <>.monad + [name <code>.local_identifier + _ (..assert ..class_names_cannot_contain_periods [name] + (not (text.contains? name.external_separator name))) + _ (..assert ..class_name_cannot_be_a_type_variable [name type_vars] + (not (list.member? text.equivalence + (list\map parser.name type_vars) + name)))] + (wrap name))) + +(def: (class^' parameter^ type_vars) + (-> (-> (List (Type Var)) (Parser (Type Parameter))) + (-> (List (Type Var)) (Parser (Type Class)))) + (do <>.monad + [[name parameters] (: (Parser [External (List (Type Parameter))]) + ($_ <>.either + (<>.and (valid_class_name type_vars) + (<>\wrap (list))) + (<code>.form (<>.and <code>.local_identifier + (<>.some (parameter^ type_vars))))))] + (wrap (type.class (name.sanitize name) parameters)))) + +(exception: #export (unexpected_type_variable {name Text} + {type_vars (List (Type Var))}) + (exception.report + ["Unexpected Type Variable" (%.text name)] + ["Expected Type Variables" (exception.enumerate parser.name type_vars)])) + +(def: (variable^ type_vars) + (-> (List (Type Var)) (Parser (Type Parameter))) + (do <>.monad + [name <code>.local_identifier + _ (..assert ..unexpected_type_variable [name type_vars] + (list.member? text.equivalence (list\map parser.name type_vars) name))] + (wrap (type.var name)))) + +(def: wildcard^ + (Parser (Type Parameter)) + (do <>.monad + [_ (<code>.this! (' ?))] + (wrap type.wildcard))) + +(template [<name> <comparison> <constructor>] + [(def: <name> + (-> (Parser (Type Class)) (Parser (Type Parameter))) + (|>> (<>.after (<code>.this! (' <comparison>))) + (<>.after ..wildcard^) + <code>.tuple + (\ <>.monad map <constructor>)))] + + [upper^ < type.upper] + [lower^ > type.lower] + ) + +(def: (parameter^ type_vars) + (-> (List (Type Var)) (Parser (Type Parameter))) + (<>.rec + (function (_ recur^) + (let [class^ (..class^' parameter^ type_vars)] + ($_ <>.either + (..variable^ type_vars) + ..wildcard^ + (upper^ class^) + (lower^ class^) + class^ + ))))) + +(def: (itself^ type) + (All [category] + (-> (Type (<| Return' Value' category)) + (Parser (Type (<| Return' Value' category))))) + (do <>.monad + [_ (<code>.identifier! ["" (..reflection type)])] + (wrap type))) + +(def: primitive^ + (Parser (Type Primitive)) + ($_ <>.either + (itself^ type.boolean) + (itself^ type.byte) + (itself^ type.short) + (itself^ type.int) + (itself^ type.long) + (itself^ type.float) + (itself^ type.double) + (itself^ type.char) + )) + +(def: array^ + (-> (Parser (Type Value)) (Parser (Type Array))) + (|>> <code>.tuple + (\ <>.monad map type.array))) + +(def: (type^ type_vars) + (-> (List (Type Var)) (Parser (Type Value))) + (<>.rec + (function (_ type^) + ($_ <>.either + ..primitive^ + (..parameter^ type_vars) + (..array^ type^) + )))) + +(def: void^ + (Parser (Type Void)) + (do <>.monad + [_ (<code>.identifier! ["" (reflection.reflection reflection.void)])] + (wrap type.void))) + +(def: (return^ type_vars) + (-> (List (Type Var)) (Parser (Type Return))) + (<>.either ..void^ + (..type^ type_vars))) + +(def: var^ + (Parser (Type Var)) + (\ <>.monad map type.var <code>.local_identifier)) + +(def: vars^ + (Parser (List (Type Var))) + (<code>.tuple (<>.some var^))) + +(def: declaration^ + (Parser (Type Declaration)) + (do <>.monad + [[name variables] (: (Parser [External (List (Type Var))]) + (<>.either (<>.and (..valid_class_name (list)) + (<>\wrap (list))) + (<code>.form (<>.and (..valid_class_name (list)) + (<>.some var^))) + ))] + (wrap (type.declaration name variables)))) + +(def: (class^ type_vars) + (-> (List (Type Var)) (Parser (Type Class))) + (class^' parameter^ type_vars)) + +(def: annotation_parameters^ + (Parser (List Annotation_Parameter)) + (<code>.record (<>.some (<>.and <code>.local_tag <code>.any)))) + +(def: annotation^ + (Parser Annotation) + (<>.either (do <>.monad + [ann_name <code>.local_identifier] + (wrap [ann_name (list)])) + (<code>.form (<>.and <code>.local_identifier + annotation_parameters^)))) + +(def: annotations^' + (Parser (List Annotation)) + (do <>.monad + [_ (<code>.this! (' #ann))] + (<code>.tuple (<>.some ..annotation^)))) + +(def: annotations^ + (Parser (List Annotation)) + (do <>.monad + [anns?? (<>.maybe ..annotations^')] + (wrap (maybe.default (list) anns??)))) + +(def: (throws_decl^ type_vars) + (-> (List (Type Var)) (Parser (List (Type Class)))) + (<| (<>.default (list)) + (do <>.monad + [_ (<code>.this! (' #throws))] + (<code>.tuple (<>.some (..class^ type_vars)))))) + +(def: (method_decl^ type_vars) + (-> (List (Type Var)) (Parser [Member_Declaration MethodDecl])) + (<code>.form (do <>.monad + [tvars (<>.default (list) ..vars^) + name <code>.local_identifier + anns ..annotations^ + inputs (<code>.tuple (<>.some (..type^ type_vars))) + output (..return^ type_vars) + exs (throws_decl^ type_vars)] + (wrap [[name #PublicP anns] {#method_tvars tvars + #method_inputs inputs + #method_output output + #method_exs exs}])))) + +(def: state_modifier^ + (Parser StateModifier) + ($_ <>.or + (<code>.this! (' #volatile)) + (<code>.this! (' #final)) + (\ <>.monad wrap []))) + +(def: (field_decl^ type_vars) + (-> (List (Type Var)) (Parser [Member_Declaration FieldDecl])) + (<>.either (<code>.form (do <>.monad + [_ (<code>.this! (' #const)) + name <code>.local_identifier + anns ..annotations^ + type (..type^ type_vars) + body <code>.any] + (wrap [[name #PublicP anns] (#ConstantField [type body])]))) + (<code>.form (do <>.monad + [pm privacy_modifier^ + sm state_modifier^ + name <code>.local_identifier + anns ..annotations^ + type (..type^ type_vars)] + (wrap [[name pm anns] (#VariableField [sm type])]))))) + +(def: (argument^ type_vars) + (-> (List (Type Var)) (Parser Argument)) + (<code>.record (<>.and <code>.local_identifier + (..type^ type_vars)))) + +(def: (arguments^ type_vars) + (-> (List (Type Var)) (Parser (List Argument))) + (<>.some (..argument^ type_vars))) + +(def: (constructor_arg^ type_vars) + (-> (List (Type Var)) (Parser (Typed Code))) + (<code>.record (<>.and (..type^ type_vars) <code>.any))) + +(def: (constructor_args^ type_vars) + (-> (List (Type Var)) (Parser (List (Typed Code)))) + (<code>.tuple (<>.some (..constructor_arg^ type_vars)))) + +(def: (constructor_method^ class_vars) + (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition])) + (<code>.form (do <>.monad + [pm privacy_modifier^ + strict_fp? (<>.parses? (<code>.this! (' #strict))) + method_vars (<>.default (list) ..vars^) + #let [total_vars (list\compose class_vars method_vars)] + [_ self_name arguments] (<code>.form ($_ <>.and + (<code>.this! (' new)) + <code>.local_identifier + (..arguments^ total_vars))) + constructor_args (..constructor_args^ total_vars) + exs (throws_decl^ total_vars) + annotations ..annotations^ + body <code>.any] + (wrap [{#member_name constructor_method_name + #member_privacy pm + #member_anns annotations} + (#ConstructorMethod strict_fp? method_vars self_name arguments constructor_args body exs)])))) + +(def: (virtual_method_def^ class_vars) + (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition])) + (<code>.form (do <>.monad + [pm privacy_modifier^ + strict_fp? (<>.parses? (<code>.this! (' #strict))) + final? (<>.parses? (<code>.this! (' #final))) + method_vars (<>.default (list) ..vars^) + #let [total_vars (list\compose class_vars method_vars)] + [name self_name arguments] (<code>.form ($_ <>.and + <code>.local_identifier + <code>.local_identifier + (..arguments^ total_vars))) + return_type (..return^ total_vars) + exs (throws_decl^ total_vars) + annotations ..annotations^ + body <code>.any] + (wrap [{#member_name name + #member_privacy pm + #member_anns annotations} + (#VirtualMethod final? strict_fp? method_vars self_name arguments return_type body exs)])))) + +(def: overriden_method_def^ + (Parser [Member_Declaration Method_Definition]) + (<code>.form (do <>.monad + [strict_fp? (<>.parses? (<code>.this! (' #strict))) + owner_class ..declaration^ + method_vars (<>.default (list) ..vars^) + #let [total_vars (list\compose (product.right (parser.declaration owner_class)) + method_vars)] + [name self_name arguments] (<code>.form ($_ <>.and + <code>.local_identifier + <code>.local_identifier + (..arguments^ total_vars))) + return_type (..return^ total_vars) + exs (throws_decl^ total_vars) + annotations ..annotations^ + body <code>.any] + (wrap [{#member_name name + #member_privacy #PublicP + #member_anns annotations} + (#OverridenMethod strict_fp? owner_class method_vars self_name arguments return_type body exs)])))) + +(def: static_method_def^ + (Parser [Member_Declaration Method_Definition]) + (<code>.form (do <>.monad + [pm privacy_modifier^ + strict_fp? (<>.parses? (<code>.this! (' #strict))) + _ (<code>.this! (' #static)) + method_vars (<>.default (list) ..vars^) + #let [total_vars method_vars] + [name arguments] (<code>.form (<>.and <code>.local_identifier + (..arguments^ total_vars))) + return_type (..return^ total_vars) + exs (throws_decl^ total_vars) + annotations ..annotations^ + body <code>.any] + (wrap [{#member_name name + #member_privacy pm + #member_anns annotations} + (#StaticMethod strict_fp? method_vars arguments return_type body exs)])))) + +(def: abstract_method_def^ + (Parser [Member_Declaration Method_Definition]) + (<code>.form (do <>.monad + [pm privacy_modifier^ + _ (<code>.this! (' #abstract)) + method_vars (<>.default (list) ..vars^) + #let [total_vars method_vars] + [name arguments] (<code>.form (<>.and <code>.local_identifier + (..arguments^ total_vars))) + return_type (..return^ total_vars) + exs (throws_decl^ total_vars) + annotations ..annotations^] + (wrap [{#member_name name + #member_privacy pm + #member_anns annotations} + (#AbstractMethod method_vars arguments return_type exs)])))) + +(def: native_method_def^ + (Parser [Member_Declaration Method_Definition]) + (<code>.form (do <>.monad + [pm privacy_modifier^ + _ (<code>.this! (' #native)) + method_vars (<>.default (list) ..vars^) + #let [total_vars method_vars] + [name arguments] (<code>.form (<>.and <code>.local_identifier + (..arguments^ total_vars))) + return_type (..return^ total_vars) + exs (throws_decl^ total_vars) + annotations ..annotations^] + (wrap [{#member_name name + #member_privacy pm + #member_anns annotations} + (#NativeMethod method_vars arguments return_type exs)])))) + +(def: (method_def^ class_vars) + (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition])) + ($_ <>.either + (..constructor_method^ class_vars) + (..virtual_method_def^ class_vars) + ..overriden_method_def^ + ..static_method_def^ + ..abstract_method_def^ + ..native_method_def^)) + +(def: partial_call^ + (Parser Partial_Call) + (<code>.form (<>.and <code>.identifier (<>.some <code>.any)))) + +(def: class_kind^ + (Parser Class_Kind) + (<>.either (do <>.monad + [_ (<code>.this! (' #class))] + (wrap #Class)) + (do <>.monad + [_ (<code>.this! (' #interface))] + (wrap #Interface)) + )) + +(def: import_member_alias^ + (Parser (Maybe Text)) + (<>.maybe (do <>.monad + [_ (<code>.this! (' #as))] + <code>.local_identifier))) + +(def: (import_member_args^ type_vars) + (-> (List (Type Var)) (Parser (List [Bit (Type Value)]))) + (<code>.tuple (<>.some (<>.and (<>.parses? (<code>.tag! ["" "?"])) + (..type^ type_vars))))) + +(def: import_member_return_flags^ + (Parser [Bit Bit Bit]) + ($_ <>.and + (<>.parses? (<code>.this! (' #io))) + (<>.parses? (<code>.this! (' #try))) + (<>.parses? (<code>.this! (' #?))))) + +(def: primitive_mode^ + (Parser Primitive_Mode) + (<>.or (<code>.tag! ["" "manual"]) + (<code>.tag! ["" "auto"]))) + +(def: (import_member_decl^ owner_vars) + (-> (List (Type Var)) (Parser Import_Member_Declaration)) + ($_ <>.either + (<code>.form (do <>.monad + [_ (<code>.this! (' #enum)) + enum_members (<>.some <code>.local_identifier)] + (wrap (#EnumDecl enum_members)))) + (<code>.form (do <>.monad + [tvars (<>.default (list) ..vars^) + _ (<code>.identifier! ["" "new"]) + ?alias import_member_alias^ + #let [total_vars (list\compose owner_vars tvars)] + ?prim_mode (<>.maybe primitive_mode^) + args (..import_member_args^ total_vars) + [io? try? maybe?] import_member_return_flags^] + (wrap (#ConstructorDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode) + #import_member_alias (maybe.default "new" ?alias) + #import_member_kind #VirtualIMK + #import_member_tvars tvars + #import_member_args args + #import_member_maybe? maybe? + #import_member_try? try? + #import_member_io? io?} + {}])) + )) + (<code>.form (do <>.monad + [kind (: (Parser ImportMethodKind) + (<>.or (<code>.tag! ["" "static"]) + (wrap []))) + tvars (<>.default (list) ..vars^) + name <code>.local_identifier + ?alias import_member_alias^ + #let [total_vars (list\compose owner_vars tvars)] + ?prim_mode (<>.maybe primitive_mode^) + args (..import_member_args^ total_vars) + [io? try? maybe?] import_member_return_flags^ + return (..return^ total_vars)] + (wrap (#MethodDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode) + #import_member_alias (maybe.default name ?alias) + #import_member_kind kind + #import_member_tvars tvars + #import_member_args args + #import_member_maybe? maybe? + #import_member_try? try? + #import_member_io? io?} + {#import_method_name name + #import_method_return return}])))) + (<code>.form (do <>.monad + [static? (<>.parses? (<code>.this! (' #static))) + name <code>.local_identifier + ?prim_mode (<>.maybe primitive_mode^) + gtype (..type^ owner_vars) + maybe? (<>.parses? (<code>.this! (' #?))) + setter? (<>.parses? (<code>.this! (' #!)))] + (wrap (#FieldAccessDecl {#import_field_mode (maybe.default #AutoPrM ?prim_mode) + #import_field_name name + #import_field_static? static? + #import_field_maybe? maybe? + #import_field_setter? setter? + #import_field_type gtype})))) + )) + +(def: bundle + (-> (List (Type Var)) (Parser [Text (List Import_Member_Declaration)])) + (|>> ..import_member_decl^ + <>.some + (<>.and <code>.text) + <code>.tuple)) + +(def: (privacy_modifier$ pm) + (-> Privacy Code) + (case pm + #PublicP (code.text "public") + #PrivateP (code.text "private") + #ProtectedP (code.text "protected") + #DefaultP (code.text "default"))) + +(def: (inheritance_modifier$ im) + (-> InheritanceModifier Code) + (case im + #FinalIM (code.text "final") + #AbstractIM (code.text "abstract") + #DefaultIM (code.text "default"))) + +(def: (annotation_parameter$ [name value]) + (-> Annotation_Parameter Code) + (` [(~ (code.text name)) (~ value)])) + +(def: (annotation$ [name params]) + (-> Annotation Code) + (` ((~ (code.text name)) (~+ (list\map annotation_parameter$ params))))) + +(template [<name> <category>] + [(def: <name> + (-> (Type <category>) Code) + (|>> ..signature code.text))] + + [var$ Var] + [parameter$ Parameter] + [value$ Value] + [return$ Return] + [declaration$ Declaration] + [class$ Class] + ) + +(def: var$' + (-> (Type Var) Code) + (|>> ..signature code.local_identifier)) + +(def: (method_decl$ [[name pm anns] method_decl]) + (-> [Member_Declaration MethodDecl] Code) + (let [(^slots [#method_tvars #method_inputs #method_output #method_exs]) method_decl] + (` ((~ (code.text name)) + [(~+ (list\map annotation$ anns))] + [(~+ (list\map var$ method_tvars))] + [(~+ (list\map class$ method_exs))] + [(~+ (list\map value$ method_inputs))] + (~ (return$ method_output)))))) + +(def: (state_modifier$ sm) + (-> StateModifier Code) + (case sm + #VolatileSM (' "volatile") + #FinalSM (' "final") + #DefaultSM (' "default"))) + +(def: (field_decl$ [[name pm anns] field]) + (-> [Member_Declaration FieldDecl] Code) + (case field + (#ConstantField class value) + (` ("constant" (~ (code.text name)) + [(~+ (list\map annotation$ anns))] + (~ (value$ class)) + (~ value) + )) + + (#VariableField sm class) + (` ("variable" (~ (code.text name)) + (~ (privacy_modifier$ pm)) + (~ (state_modifier$ sm)) + [(~+ (list\map annotation$ anns))] + (~ (value$ class)) + )) + )) + +(def: (argument$ [name type]) + (-> Argument Code) + (` [(~ (code.text name)) (~ (value$ type))])) + +(def: (constructor_arg$ [class term]) + (-> (Typed Code) Code) + (` [(~ (value$ class)) (~ term)])) + +(def: (method_def$ replacer super_class [[name pm anns] method_def]) + (-> (-> Code Code) (Type Class) [Member_Declaration Method_Definition] Code) + (case method_def + (#ConstructorMethod strict_fp? type_vars self_name arguments constructor_args body exs) + (` ("init" + (~ (privacy_modifier$ pm)) + (~ (code.bit strict_fp?)) + [(~+ (list\map annotation$ anns))] + [(~+ (list\map var$ type_vars))] + [(~+ (list\map class$ exs))] + (~ (code.text self_name)) + [(~+ (list\map argument$ arguments))] + [(~+ (list\map constructor_arg$ constructor_args))] + (~ (pre_walk_replace replacer body)) + )) + + (#VirtualMethod final? strict_fp? type_vars self_name arguments return_type body exs) + (` ("virtual" + (~ (code.text name)) + (~ (privacy_modifier$ pm)) + (~ (code.bit final?)) + (~ (code.bit strict_fp?)) + [(~+ (list\map annotation$ anns))] + [(~+ (list\map var$ type_vars))] + (~ (code.text self_name)) + [(~+ (list\map argument$ arguments))] + (~ (return$ return_type)) + [(~+ (list\map class$ exs))] + (~ (pre_walk_replace replacer body)))) + + (#OverridenMethod strict_fp? declaration type_vars self_name arguments return_type body exs) + (let [super_replacer (parser->replacer (<code>.form (do <>.monad + [_ (<code>.this! (' ::super!)) + args (<code>.tuple (<>.exactly (list.size arguments) <code>.any))] + (wrap (` ("jvm member invoke special" + (~ (code.text (product.left (parser.read_class super_class)))) + (~ (code.text name)) + (~' _jvm_this) + (~+ (|> args + (list.zip/2 (list\map product.right arguments)) + (list\map ..decorate_input)))))))))] + (` ("override" + (~ (declaration$ declaration)) + (~ (code.text name)) + (~ (code.bit strict_fp?)) + [(~+ (list\map annotation$ anns))] + [(~+ (list\map var$ type_vars))] + (~ (code.text self_name)) + [(~+ (list\map argument$ arguments))] + (~ (return$ return_type)) + [(~+ (list\map class$ exs))] + (~ (|> body + (pre_walk_replace replacer) + (pre_walk_replace super_replacer))) + ))) + + (#StaticMethod strict_fp? type_vars arguments return_type body exs) + (` ("static" + (~ (code.text name)) + (~ (privacy_modifier$ pm)) + (~ (code.bit strict_fp?)) + [(~+ (list\map annotation$ anns))] + [(~+ (list\map var$ type_vars))] + [(~+ (list\map class$ exs))] + [(~+ (list\map argument$ arguments))] + (~ (return$ return_type)) + (~ (pre_walk_replace replacer body)))) + + (#AbstractMethod type_vars arguments return_type exs) + (` ("abstract" + (~ (code.text name)) + (~ (privacy_modifier$ pm)) + [(~+ (list\map annotation$ anns))] + [(~+ (list\map var$ type_vars))] + [(~+ (list\map class$ exs))] + [(~+ (list\map argument$ arguments))] + (~ (return$ return_type)))) + + (#NativeMethod type_vars arguments return_type exs) + (` ("native" + (~ (code.text name)) + (~ (privacy_modifier$ pm)) + [(~+ (list\map annotation$ anns))] + [(~+ (list\map var$ type_vars))] + [(~+ (list\map class$ exs))] + [(~+ (list\map argument$ arguments))] + (~ (return$ return_type)))) + )) + +(def: (complete_call$ g!obj [method args]) + (-> Code Partial_Call Code) + (` ((~ (code.identifier method)) (~+ args) (~ g!obj)))) + +(def: $Object + (Type Class) + (type.class "java.lang.Object" (list))) + +(syntax: #export (class: + {#let [! <>.monad]} + {im inheritance_modifier^} + {[full_class_name class_vars] (\ ! map parser.declaration ..declaration^)} + {super (<>.default $Object + (class^ class_vars))} + {interfaces (<>.default (list) + (<code>.tuple (<>.some (class^ class_vars))))} + {annotations ..annotations^} + {fields (<>.some (..field_decl^ class_vars))} + {methods (<>.some (..method_def^ class_vars))}) + {#.doc (doc "Allows defining JVM classes in Lux code." + "For example:" + (class: #final (TestClass A) [Runnable] + ## Fields + (#private foo boolean) + (#private bar A) + (#private baz java/lang/Object) + ## Methods + (#public [] (new [value A]) [] + (exec (:= ::foo #1) + (:= ::bar value) + (:= ::baz "") + [])) + (#public (virtual) java/lang/Object + "") + (#public #static (static) java/lang/Object + "") + (Runnable [] (run) void + []) + ) + + "The tuple corresponds to parent interfaces." + "An optional super-class can be specified before the tuple. If not specified, java.lang.Object will be assumed." + "Fields and methods defined in the class can be used with special syntax." + "For example:" + "::resolved, for accessing the 'resolved' field." + "(:= ::resolved #1) for modifying it." + "(::new! []) for calling the class's constructor." + "(::resolve! container [value]) for calling the 'resolve' method." + )} + (do meta.monad + [current_module meta.current_module_name + #let [fully_qualified_class_name (name.qualify current_module full_class_name) + field_parsers (list\map (field->parser fully_qualified_class_name) fields) + method_parsers (list\map (method->parser fully_qualified_class_name) methods) + replacer (parser->replacer (list\fold <>.either + (<>.fail "") + (list\compose field_parsers method_parsers)))]] + (wrap (list (` ("jvm class" + (~ (declaration$ (type.declaration (name.qualify current_module full_class_name) class_vars))) + (~ (class$ super)) + [(~+ (list\map class$ interfaces))] + (~ (inheritance_modifier$ im)) + [(~+ (list\map annotation$ annotations))] + [(~+ (list\map field_decl$ fields))] + [(~+ (list\map (method_def$ replacer super) methods))])))))) + +(syntax: #export (interface: + {#let [! <>.monad]} + {[full_class_name class_vars] (\ ! map parser.declaration ..declaration^)} + {supers (<>.default (list) + (<code>.tuple (<>.some (class^ class_vars))))} + {annotations ..annotations^} + {members (<>.some (..method_decl^ class_vars))}) + {#.doc (doc "Allows defining JVM interfaces." + (interface: TestInterface + ([] foo [boolean String] void #throws [Exception])))} + (do meta.monad + [current_module meta.current_module_name] + (wrap (list (` ("jvm class interface" + (~ (declaration$ (type.declaration (name.qualify current_module full_class_name) class_vars))) + [(~+ (list\map class$ supers))] + [(~+ (list\map annotation$ annotations))] + (~+ (list\map method_decl$ members)))))))) + +(syntax: #export (object + {class_vars ..vars^} + {super (<>.default $Object + (class^ class_vars))} + {interfaces (<>.default (list) + (<code>.tuple (<>.some (class^ class_vars))))} + {constructor_args (..constructor_args^ class_vars)} + {methods (<>.some ..overriden_method_def^)}) + {#.doc (doc "Allows defining anonymous classes." + "The 1st tuple corresponds to class-level type-variables." + "The 2nd tuple corresponds to parent interfaces." + "The 3rd tuple corresponds to arguments to the super class constructor." + "An optional super-class can be specified before the 1st tuple. If not specified, java.lang.Object will be assumed." + (object [] [Runnable] + [] + (Runnable [] (run self) void + (exec (do_something some_value) + []))) + )} + (wrap (list (` ("jvm class anonymous" + [(~+ (list\map var$ class_vars))] + (~ (class$ super)) + [(~+ (list\map class$ interfaces))] + [(~+ (list\map constructor_arg$ constructor_args))] + [(~+ (list\map (method_def$ function.identity super) methods))]))))) + +(syntax: #export (null) + {#.doc (doc "Null object reference." + (null))} + (wrap (list (` ("jvm object null"))))) + +(def: #export (null? obj) + {#.doc (doc "Test for null object reference." + (= (null? (null)) + true) + (= (null? "YOLO") + false))} + (-> (primitive "java.lang.Object") Bit) + ("jvm object null?" obj)) + +(syntax: #export (??? expr) + {#.doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it." + (= (??? (: java/lang/String (null))) + #.None) + (= (??? "YOLO") + (#.Some "YOLO")))} + (with_gensyms [g!temp] + (wrap (list (` (let [(~ g!temp) (~ expr)] + (if ("jvm object null?" (~ g!temp)) + #.None + (#.Some (~ g!temp))))))))) + +(syntax: #export (!!! expr) + {#.doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType." + "A #.None would get translated into a (null)." + (= (null) + (!!! (??? (: java/lang/Thread (null))))) + (= "foo" + (!!! (??? "foo"))))} + (with_gensyms [g!value] + (wrap (list (` ({(#.Some (~ g!value)) + (~ g!value) + + #.None + ("jvm object null")} + (~ expr))))))) + +(syntax: #export (check {class (..type^ (list))} + {unchecked (<>.maybe <code>.any)}) + {#.doc (doc "Checks whether an object is an instance of a particular class." + "Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes." + (case (check String "YOLO") + (#.Some value_as_string) + #.None))} + (with_gensyms [g!_ g!unchecked] + (let [class_name (..reflection class) + class_type (` (.primitive (~ (code.text class_name)))) + check_type (` (.Maybe (~ class_type))) + check_code (` (if ("jvm object instance?" (~ (code.text class_name)) (~ g!unchecked)) + (#.Some (.:as (~ class_type) + (~ g!unchecked))) + #.None))] + (case unchecked + (#.Some unchecked) + (wrap (list (` (: (~ check_type) + (let [(~ g!unchecked) (~ unchecked)] + (~ check_code)))))) + + #.None + (wrap (list (` (: (-> (primitive "java.lang.Object") (~ check_type)) + (function ((~ g!_) (~ g!unchecked)) + (~ check_code)))))) + )))) + +(syntax: #export (synchronized lock body) + {#.doc (doc "Evaluates body, while holding a lock on a given object." + (synchronized object_to_be_locked + (exec (do_something ___) + (do_something_else ___) + (finish_the_computation ___))))} + (wrap (list (` ("jvm object synchronized" (~ lock) (~ body)))))) + +(syntax: #export (do_to obj {methods (<>.some partial_call^)}) + {#.doc (doc "Call a variety of methods on an object. Then, return the object." + (do_to object + (ClassName::method1 arg0 arg1 arg2) + (ClassName::method2 arg3 arg4 arg5)))} + (with_gensyms [g!obj] + (wrap (list (` (let [(~ g!obj) (~ obj)] + (exec (~+ (list\map (complete_call$ g!obj) methods)) + (~ g!obj)))))))) + +(def: (class_import$ declaration) + (-> (Type Declaration) Code) + (let [[full_name params] (parser.declaration declaration) + def_name (..internal full_name) + params' (list\map ..var$' params)] + (` (def: (~ (code.identifier ["" def_name])) + {#..jvm_class (~ (code.text (..internal full_name)))} + .Type + (All [(~+ params')] + (primitive (~ (code.text full_name)) + [(~+ params')])))))) + +(def: (member_type_vars class_tvars member) + (-> (List (Type Var)) Import_Member_Declaration (List (Type Var))) + (case member + (#ConstructorDecl [commons _]) + (list\compose class_tvars (get@ #import_member_tvars commons)) + + (#MethodDecl [commons _]) + (case (get@ #import_member_kind commons) + #StaticIMK + (get@ #import_member_tvars commons) + + _ + (list\compose class_tvars (get@ #import_member_tvars commons))) + + _ + class_tvars)) + +(def: (member_def_arg_bindings vars member) + (-> (List (Type Var)) Import_Member_Declaration (Meta [(List [Bit Code]) (List (Type Value)) (List Code)])) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (let [(^slots [#import_member_tvars #import_member_args]) commons] + (do {! meta.monad} + [arg_inputs (monad.map ! + (: (-> [Bit (Type Value)] (Meta [Bit Code])) + (function (_ [maybe? _]) + (with_gensyms [arg_name] + (wrap [maybe? arg_name])))) + import_member_args) + #let [input_jvm_types (list\map product.right import_member_args) + arg_types (list\map (: (-> [Bit (Type Value)] Code) + (function (_ [maybe? arg]) + (let [arg_type (value_type (get@ #import_member_mode commons) arg)] + (if maybe? + (` (Maybe (~ arg_type))) + arg_type)))) + import_member_args)]] + (wrap [arg_inputs input_jvm_types arg_types]))) + + _ + (\ meta.monad wrap [(list) (list) (list)]))) + +(def: (decorate_return_maybe member never_null? unboxed return_term) + (-> Import_Member_Declaration Bit (Type Value) Code Code) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (cond (or never_null? + (dictionary.key? ..boxes unboxed)) + return_term + + (get@ #import_member_maybe? commons) + (` (??? (~ return_term))) + + ## else + (let [g!temp (` ((~' ~') (~ (code.identifier ["" " Ω "]))))] + (` (let [(~ g!temp) (~ return_term)] + (if (not (..null? (:as (primitive "java.lang.Object") + (~ g!temp)))) + (~ g!temp) + (error! "Cannot produce null references from method calls.")))))) + + _ + return_term)) + +(template [<name> <tag> <term_trans>] + [(def: (<name> member return_term) + (-> Import_Member_Declaration Code Code) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (if (get@ <tag> commons) + <term_trans> + return_term) + + _ + return_term))] + + [decorate_return_try #import_member_try? (` (.try (~ return_term)))] + [decorate_return_io #import_member_io? (` ((~! io.io) (~ return_term)))] + ) + +(def: $String + (type.class "java.lang.String" (list))) + +(template [<input?> <name> <unbox/box> <special+>] + [(def: (<name> mode [unboxed raw]) + (-> Primitive_Mode [(Type Value) Code] Code) + (let [[unboxed refined post] (: [(Type Value) Code (List Code)] + (case mode + #ManualPrM + [unboxed raw (list)] + + #AutoPrM + (with_expansions [<special+>' (template.splice <special+>) + <cond_cases> (template [<old> <new> <pre> <post>] + [(\ type.equivalence = <old> unboxed) + (with_expansions [<post>' (template.splice <post>)] + [<new> + (` (.|> (~ raw) (~+ <pre>))) + (list <post>')])] + + <special+>')] + (cond <cond_cases> + ## else + [unboxed + (if <input?> + (` ("jvm object cast" (~ raw))) + raw) + (list)])))) + unboxed/boxed (case (dictionary.get unboxed ..boxes) + (#.Some boxed) + (<unbox/box> unboxed boxed refined) + + #.None + refined)] + (case post + #.Nil + unboxed/boxed + + _ + (` (.|> (~ unboxed/boxed) (~+ post))))))] + + [#1 auto_convert_input ..unbox + [[type.boolean type.boolean (list (` (.: .Bit)) (` (.:as (.primitive (~ (code.text box.boolean)))))) []] + [type.byte type.byte (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_byte)) []] + [type.short type.short (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_short)) []] + [type.int type.int (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_int)) []] + [type.long type.long (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long)))))) []] + [type.float type.float (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double))))) (` ..double_to_float)) []] + [type.double type.double (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double)))))) []] + [..$String ..$String (list (` (.: .Text)) (` (.:as (.primitive (~ (code.text (..reflection ..$String))))))) []] + [(type.class box.boolean (list)) (type.class box.boolean (list)) (list (` (.: .Bit)) (` (.:as (.primitive (~ (code.text box.boolean)))))) []] + [(type.class box.long (list)) (type.class box.long (list)) (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long)))))) []] + [(type.class box.double (list)) (type.class box.double (list)) (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double)))))) []]]] + [#0 auto_convert_output ..box + [[type.boolean type.boolean (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:as .Bit))]] + [type.byte type.long (list (` "jvm conversion byte-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]] + [type.short type.long (list (` "jvm conversion short-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]] + [type.int type.long (list (` "jvm conversion int-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]] + [type.long type.long (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]] + [type.float type.double (list (` "jvm conversion float-to-double")) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]] + [type.double type.double (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]] + [..$String ..$String (list) [(` (.: (.primitive (~ (code.text (..reflection ..$String)))))) (` (.:as .Text))]] + [(type.class box.boolean (list)) (type.class box.boolean (list)) (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:as .Bit))]] + [(type.class box.long (list)) (type.class box.long (list)) (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]] + [(type.class box.double (list)) (type.class box.double (list)) (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]]]] + ) + +(def: (un_quote quoted) + (-> Code Code) + (` ((~' ~) (~ quoted)))) + +(def: (jvm_invoke_inputs mode classes inputs) + (-> Primitive_Mode (List (Type Value)) (List [Bit Code]) (List Code)) + (|> inputs + (list.zip/2 classes) + (list\map (function (_ [class [maybe? input]]) + (|> (if maybe? + (` (: (.primitive (~ (code.text (..reflection class)))) + ((~! !!!) (~ (un_quote input))))) + (un_quote input)) + [class] + (auto_convert_input mode)))))) + +(def: (import_name format class member) + (-> Text Text Text Text) + (|> format + (text.replace_all "#" class) + (text.replace_all "." member))) + +(def: (member_def_interop vars kind class [arg_function_inputs input_jvm_types arg_types] member method_prefix import_format) + (-> (List (Type Var)) Class_Kind (Type Declaration) [(List [Bit Code]) (List (Type Value)) (List Code)] Import_Member_Declaration Text Text (Meta (List Code))) + (let [[full_name class_tvars] (parser.declaration class)] + (case member + (#EnumDecl enum_members) + (do meta.monad + [#let [enum_type (: Code + (case class_tvars + #.Nil + (` (primitive (~ (code.text full_name)))) + + _ + (let [=class_tvars (list\map ..var$' class_tvars)] + (` (All [(~+ =class_tvars)] (primitive (~ (code.text full_name)) [(~+ =class_tvars)])))))) + getter_interop (: (-> Text Code) + (function (_ name) + (let [getter_name (code.identifier ["" (..import_name import_format method_prefix name)])] + (` (def: (~ getter_name) + (~ enum_type) + (~ (get_static_field full_name name)))))))]] + (wrap (list\map getter_interop enum_members))) + + (#ConstructorDecl [commons _]) + (do meta.monad + [#let [classT (type.class full_name (list)) + def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))]) + jvm_interop (|> [classT + (` ("jvm member invoke constructor" + [(~+ (list\map ..var$ class_tvars))] + (~ (code.text full_name)) + [(~+ (list\map ..var$ (get@ #import_member_tvars commons)))] + (~+ (|> (jvm_invoke_inputs (get@ #import_member_mode commons) input_jvm_types arg_function_inputs) + (list.zip/2 input_jvm_types) + (list\map ..decorate_input)))))] + (auto_convert_output (get@ #import_member_mode commons)) + (decorate_return_maybe member true classT) + (decorate_return_try member) + (decorate_return_io member))]] + (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs))) + ((~' wrap) (.list (.` (~ jvm_interop))))))))) + + (#MethodDecl [commons method]) + (with_gensyms [g!obj] + (do meta.monad + [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))]) + (^slots [#import_member_kind]) commons + (^slots [#import_method_name]) method + [jvm_op object_ast] (: [Text (List Code)] + (case import_member_kind + #StaticIMK + ["jvm member invoke static" + (list)] + + #VirtualIMK + (case kind + #Class + ["jvm member invoke virtual" + (list g!obj)] + + #Interface + ["jvm member invoke interface" + (list g!obj)] + ))) + method_return (get@ #import_method_return method) + callC (: Code + (` ((~ (code.text jvm_op)) + [(~+ (list\map ..var$ class_tvars))] + (~ (code.text full_name)) + (~ (code.text import_method_name)) + [(~+ (list\map ..var$ (get@ #import_member_tvars commons)))] + (~+ (|> object_ast + (list\map ..un_quote) + (list.zip/2 (list (type.class full_name (list)))) + (list\map (auto_convert_input (get@ #import_member_mode commons))))) + (~+ (|> (jvm_invoke_inputs (get@ #import_member_mode commons) input_jvm_types arg_function_inputs) + (list.zip/2 input_jvm_types) + (list\map ..decorate_input)))))) + jvm_interop (: Code + (case (type.void? method_return) + (#.Left method_return) + (|> [method_return + callC] + (auto_convert_output (get@ #import_member_mode commons)) + (decorate_return_maybe member false method_return) + (decorate_return_try member) + (decorate_return_io member)) + + + (#.Right method_return) + (|> callC + (decorate_return_try member) + (decorate_return_io member))))]] + (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs)) (~+ object_ast)) + ((~' wrap) (.list (.` (~ jvm_interop)))))))))) + + (#FieldAccessDecl fad) + (do meta.monad + [#let [(^open ".") fad + getter_name (code.identifier ["" (..import_name import_format method_prefix import_field_name)]) + setter_name (code.identifier ["" (..import_name import_format method_prefix (format import_field_name "!"))])] + getter_interop (with_gensyms [g!obj] + (let [getter_call (if import_field_static? + (` ((~ getter_name))) + (` ((~ getter_name) (~ g!obj)))) + getter_body (<| (auto_convert_output import_field_mode) + [import_field_type + (if import_field_static? + (get_static_field full_name import_field_name) + (get_virtual_field full_name import_field_name (un_quote g!obj)))]) + getter_body (if import_field_maybe? + (` ((~! ???) (~ getter_body))) + getter_body) + getter_body (if import_field_setter? + (` ((~! io.io) (~ getter_body))) + getter_body)] + (wrap (` ((~! syntax:) (~ getter_call) + ((~' wrap) (.list (.` (~ getter_body))))))))) + setter_interop (: (Meta (List Code)) + (if import_field_setter? + (with_gensyms [g!obj g!value] + (let [setter_call (if import_field_static? + (` ((~ setter_name) (~ g!value))) + (` ((~ setter_name) (~ g!value) (~ g!obj)))) + setter_value (|> [import_field_type (un_quote g!value)] + (auto_convert_input import_field_mode)) + setter_value (if import_field_maybe? + (` ((~! !!!) (~ setter_value))) + setter_value) + setter_command (format (if import_field_static? "jvm putstatic" "jvm putfield") + ":" full_name ":" import_field_name) + g!obj+ (: (List Code) + (if import_field_static? + (list) + (list (un_quote g!obj))))] + (wrap (list (` ((~! syntax:) (~ setter_call) + ((~' wrap) (.list (.` ((~! io.io) ((~ (code.text setter_command)) (~+ g!obj+) (~ setter_value)))))))))))) + (wrap (list))))] + (wrap (list& getter_interop setter_interop))) + ))) + +(def: (member_import$ vars kind class [import_format member]) + (-> (List (Type Var)) Class_Kind (Type Declaration) [Text Import_Member_Declaration] (Meta (List Code))) + (let [[full_name _] (parser.declaration class) + method_prefix (..internal full_name)] + (do meta.monad + [=args (member_def_arg_bindings vars member)] + (member_def_interop vars kind class =args member method_prefix import_format)))) + +(def: interface? + (All [a] (-> (primitive "java.lang.Class" [a]) Bit)) + (|>> ("jvm member invoke virtual" [] "java.lang.Class" "isInterface" []) + "jvm object cast" + (: ..Boolean) + (:as Bit))) + +(def: load_class + (-> External (Try (primitive "java.lang.Class" [Any]))) + (|>> (:as (primitive "java.lang.String")) + ["Ljava/lang/String;"] + ("jvm member invoke static" [] "java.lang.Class" "forName" []) + try)) + +(def: (class_kind declaration) + (-> (Type Declaration) (Meta Class_Kind)) + (let [[class_name _] (parser.declaration declaration)] + (case (load_class class_name) + (#.Right class) + (\ meta.monad wrap (if (interface? class) + #Interface + #Class)) + + (#.Left _) + (meta.fail (format "Unknown class: " class_name))))) + +(syntax: #export (import: + {declaration ..declaration^} + {#let [[class_name class_type_vars] (parser.declaration declaration)]} + {bundles (<>.some (..bundle class_type_vars))}) + {#.doc (doc "Allows importing JVM classes, and using them as types." + "Their methods, fields and enum options can also be imported." + (import: java/lang/Object + ["#::." + (new []) + (equals [java/lang/Object] boolean) + (wait [int] #io #try void)]) + + "Special options can also be given for the return values." + "#? means that the values will be returned inside a Maybe type. That way, null becomes #.None." + "#try means that the computation might throw an exception, and the return value will be wrapped by the Try type." + "#io means the computation has side effects, and will be wrapped by the IO type." + "These options must show up in the following order [#io #try #?] (although, each option can be used independently)." + (import: java/lang/String + ["#::." + (new [[byte]]) + (#static valueOf [char] java/lang/String) + (#static valueOf #as int_valueOf [int] java/lang/String)]) + + (import: (java/util/List e) + ["#::." + (size [] int) + (get [int] e)]) + + (import: (java/util/ArrayList a) + ["#::." + ([T] toArray [[T]] [T])]) + + "The class-type that is generated is of the fully-qualified name." + "This avoids a clash between the java.util.List type, and Lux's own List type." + "All enum options to be imported must be specified." + (import: java/lang/Character$UnicodeScript + ["#::." + (#enum ARABIC CYRILLIC LATIN)]) + + "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-vars." + "Lux types, such as Maybe cannot be named (otherwise, they'd be confused for Java classes)." + (import: (lux/concurrency/promise/JvmPromise A) + ["#::." + (resolve [A] boolean) + (poll [] A) + (wasResolved [] boolean) + (waitOn [lux/Function] void) + (#static [A] make [A] (lux/concurrency/promise/JvmPromise A))]) + + "Also, the names of the imported members will look like Class::member" + (java/lang/Object::new []) + (java/lang/Object::equals [other_object] my_object) + (java/util/List::size [] my_list) + java/lang/Character$UnicodeScript::LATIN + )} + (do {! meta.monad} + [kind (class_kind declaration) + =members (|> bundles + (list\map (function (_ [import_format members]) + (list\map (|>> [import_format]) members))) + list.concat + (monad.map ! (member_import$ class_type_vars kind declaration)))] + (wrap (list& (class_import$ declaration) (list\join =members))))) + +(syntax: #export (array {type (..type^ (list))} + size) + {#.doc (doc "Create an array of the given type, with the given size." + (array java/lang/Object 10))} + (let [g!size (` (|> (~ size) + (.: .Nat) + (.:as (.primitive (~ (code.text box.long)))) + "jvm object cast" + "jvm conversion long-to-int"))] + (`` (cond (~~ (template [<primitive> <array_op>] + [(\ type.equivalence = <primitive> type) + (wrap (list (` (<array_op> (~ g!size)))))] + + [type.boolean "jvm array new boolean"] + [type.byte "jvm array new byte"] + [type.short "jvm array new short"] + [type.int "jvm array new int"] + [type.long "jvm array new long"] + [type.float "jvm array new float"] + [type.double "jvm array new double"] + [type.char "jvm array new char"])) + ## else + (wrap (list (` (: (~ (value_type #ManualPrM (type.array type))) + ("jvm array new object" (~ g!size)))))))))) + +(exception: #export (cannot_convert_to_jvm_type {type .Type}) + (exception.report + ["Lux Type" (%.type type)])) + +(with_expansions [<failure> (as_is (meta.fail (exception.construct ..cannot_convert_to_jvm_type [type])))] + (def: (lux_type->jvm_type type) + (-> .Type (Meta (Type Value))) + (if (lux_type\= .Any type) + (\ meta.monad wrap $Object) + (case type + (#.Primitive name params) + (`` (cond (~~ (template [<type>] + [(text\= (..reflection <type>) name) + (case params + #.Nil + (\ meta.monad wrap <type>) + + _ + <failure>)] + + [type.boolean] + [type.byte] + [type.short] + [type.int] + [type.long] + [type.float] + [type.double] + [type.char])) + + (~~ (template [<type>] + [(text\= (..reflection (type.array <type>)) name) + (case params + #.Nil + (\ meta.monad wrap (type.array <type>)) + + _ + <failure>)] + + [type.boolean] + [type.byte] + [type.short] + [type.int] + [type.long] + [type.float] + [type.double] + [type.char])) + + (text\= array.type_name name) + (case params + (#.Cons elementLT #.Nil) + (\ meta.monad map type.array + (lux_type->jvm_type elementLT)) + + _ + <failure>) + + (text.starts_with? descriptor.array_prefix name) + (case params + #.Nil + (let [[_ unprefixed] (maybe.assume (text.split_with descriptor.array_prefix name))] + (\ meta.monad map type.array + (lux_type->jvm_type (#.Primitive unprefixed (list))))) + + _ + <failure>) + + ## else + (\ meta.monad map (type.class name) + (: (Meta (List (Type Parameter))) + (monad.map meta.monad + (function (_ paramLT) + (do meta.monad + [paramJT (lux_type->jvm_type paramLT)] + (case (parser.parameter? paramJT) + (#.Some paramJT) + (wrap paramJT) + + #.None + <failure>))) + params))))) + + (#.Apply A F) + (case (lux_type.apply (list A) F) + #.None + <failure> + + (#.Some type') + (lux_type->jvm_type type')) + + (#.Named _ type') + (lux_type->jvm_type type') + + _ + <failure>)))) + +(syntax: #export (array_length array) + {#.doc (doc "Gives the length of an array." + (array_length my_array))} + (case array + [_ (#.Identifier array_name)] + (do meta.monad + [array_type (meta.find_type array_name) + array_jvm_type (lux_type->jvm_type array_type) + #let [g!extension (code.text (`` (cond (~~ (template [<primitive> <extension>] + [(\ type.equivalence = + (type.array <primitive>) + array_jvm_type) + <extension>] + + [type.boolean "jvm array length boolean"] + [type.byte "jvm array length byte"] + [type.short "jvm array length short"] + [type.int "jvm array length int"] + [type.long "jvm array length long"] + [type.float "jvm array length float"] + [type.double "jvm array length double"] + [type.char "jvm array length char"])) + + ## else + "jvm array length object")))]] + (wrap (list (` (.|> ((~ g!extension) (~ array)) + "jvm conversion int-to-long" + "jvm object cast" + (.: (.primitive (~ (code.text box.long)))) + (.:as .Nat)))))) + + _ + (with_gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (..array_length (~ g!array))))))))) + +(syntax: #export (array_read idx array) + {#.doc (doc "Loads an element from an array." + (array_read 10 my_array))} + (case array + [_ (#.Identifier array_name)] + (do meta.monad + [array_type (meta.find_type array_name) + array_jvm_type (lux_type->jvm_type array_type) + #let [g!idx (` (.|> (~ idx) + (.: .Nat) + (.:as (.primitive (~ (code.text box.long)))) + "jvm object cast" + "jvm conversion long-to-int"))]] + (`` (cond (~~ (template [<primitive> <extension> <box>] + [(\ type.equivalence = + (type.array <primitive>) + array_jvm_type) + (wrap (list (` (.|> (<extension> (~ g!idx) (~ array)) + "jvm object cast" + (.: (.primitive (~ (code.text <box>))))))))] + + [type.boolean "jvm array read boolean" box.boolean] + [type.byte "jvm array read byte" box.byte] + [type.short "jvm array read short" box.short] + [type.int "jvm array read int" box.int] + [type.long "jvm array read long" box.long] + [type.float "jvm array read float" box.float] + [type.double "jvm array read double" box.double] + [type.char "jvm array read char" box.char])) + + ## else + (wrap (list (` ("jvm array read object" (~ g!idx) (~ array)))))))) + + _ + (with_gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (..array_read (~ idx) (~ g!array))))))))) + +(syntax: #export (array_write idx value array) + {#.doc (doc "Stores an element into an array." + (array_write 10 my_object my_array))} + (case array + [_ (#.Identifier array_name)] + (do meta.monad + [array_type (meta.find_type array_name) + array_jvm_type (lux_type->jvm_type array_type) + #let [g!idx (` (.|> (~ idx) + (.: .Nat) + (.:as (.primitive (~ (code.text box.long)))) + "jvm object cast" + "jvm conversion long-to-int"))]] + (`` (cond (~~ (template [<primitive> <extension> <box>] + [(\ type.equivalence = + (type.array <primitive>) + array_jvm_type) + (let [g!value (` (.|> (~ value) + (.:as (.primitive (~ (code.text <box>)))) + "jvm object cast"))] + (wrap (list (` (<extension> (~ g!idx) (~ g!value) (~ array))))))] + + [type.boolean "jvm array write boolean" box.boolean] + [type.byte "jvm array write byte" box.byte] + [type.short "jvm array write short" box.short] + [type.int "jvm array write int" box.int] + [type.long "jvm array write long" box.long] + [type.float "jvm array write float" box.float] + [type.double "jvm array write double" box.double] + [type.char "jvm array write char" box.char])) + + ## else + (wrap (list (` ("jvm array write object" (~ g!idx) (~ value) (~ array)))))))) + + _ + (with_gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (..array_write (~ idx) (~ value) (~ g!array))))))))) + +(syntax: #export (class_for {type (..type^ (list))}) + {#.doc (doc "Loads the class as a java.lang.Class object." + (class_for java/lang/String))} + (wrap (list (` ("jvm object class" (~ (code.text (..reflection type)))))))) + +(syntax: #export (type {type (..type^ (list))}) + (wrap (list (..value_type #ManualPrM type)))) + +(exception: #export (cannot_cast_to_non_object {type (Type Value)}) + (exception.report + ["Signature" (..signature type)] + ["Reflection" (..reflection type)])) + +(syntax: #export (:cast {type (..type^ (list))} + object) + (case [(parser.array? type) + (parser.class? type)] + (^or [(#.Some _) _] [_ (#.Some _)]) + (wrap (list (` (.: (~ (..value_type #ManualPrM type)) + ("jvm object cast" (~ object)))))) + + _ + (meta.fail (exception.construct ..cannot_cast_to_non_object [type])))) diff --git a/stdlib/source/library/lux/ffi.lua.lux b/stdlib/source/library/lux/ffi.lua.lux new file mode 100644 index 000000000..0099865f5 --- /dev/null +++ b/stdlib/source/library/lux/ffi.lua.lux @@ -0,0 +1,310 @@ +(.module: + [library + [lux #* + ["." meta] + ["@" target] + [abstract + [monad (#+ do)]] + [control + ["." io] + ["<>" parser ("#\." monad) + ["<.>" code (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text + ["%" format]] + [collection + ["." list ("#\." functor fold)]]] + [type + abstract] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code] + ["." template]]]]) + +(abstract: #export (Object brand) Any) + +(template [<name>] + [(with_expansions [<brand> (template.identifier [<name> "'"])] + (abstract: #export <brand> Any) + (type: #export <name> + (..Object <brand>)))] + + [Nil] + [Function] + [Table] + ) + +(template [<name> <type>] + [(type: #export <name> + <type>)] + + [Boolean Bit] + [Integer Int] + [Float Frac] + [String Text] + ) + +(type: Nilable + [Bit Code]) + +(def: nilable + (Parser Nilable) + (let [token (' #?)] + (<| (<>.and (<>.parses? (<code>.this! token))) + (<>.after (<>.not (<code>.this! token))) + <code>.any))) + +(type: Field + [Bit Text Nilable]) + +(def: static! + (Parser Any) + (<code>.this! (' #static))) + +(def: field + (Parser Field) + (<code>.form ($_ <>.and + (<>.parses? ..static!) + <code>.local_identifier + ..nilable))) + +(def: constant + (Parser Field) + (<code>.form ($_ <>.and + (<>\wrap true) + <code>.local_identifier + ..nilable))) + +(type: Common_Method + {#name Text + #alias (Maybe Text) + #inputs (List Nilable) + #io? Bit + #try? Bit + #output Nilable}) + +(type: Static_Method Common_Method) +(type: Virtual_Method Common_Method) + +(type: Method + (#Static Static_Method) + (#Virtual Virtual_Method)) + +(def: common_method + (Parser Common_Method) + ($_ <>.and + <code>.local_identifier + (<>.maybe (<>.after (<code>.this! (' #as)) <code>.local_identifier)) + (<code>.tuple (<>.some ..nilable)) + (<>.parses? (<code>.this! (' #io))) + (<>.parses? (<code>.this! (' #try))) + ..nilable)) + +(def: static_method + (<>.after ..static! ..common_method)) + +(def: method + (Parser Method) + (<code>.form (<>.or ..static_method + ..common_method))) + +(type: Member + (#Field Field) + (#Method Method)) + +(def: member + (Parser Member) + ($_ <>.or + ..field + ..method + )) + +(def: input_variables + (-> (List Nilable) (List [Bit Code])) + (|>> list.enumeration + (list\map (function (_ [idx [nilable? type]]) + [nilable? (|> idx %.nat code.local_identifier)])))) + +(def: (nilable_type [nilable? type]) + (-> Nilable Code) + (if nilable? + (` (.Maybe (~ type))) + type)) + +(def: (with_nil g!temp [nilable? input]) + (-> Code [Bit Code] Code) + (if nilable? + (` (case (~ input) + (#.Some (~ g!temp)) + (~ g!temp) + + #.Nil + ("lua object nil"))) + input)) + +(def: (without_nil g!temp [nilable? outputT] output) + (-> Code Nilable Code Code) + (if nilable? + (` (let [(~ g!temp) (~ output)] + (if ("lua object nil?" (~ g!temp)) + #.None + (#.Some (~ g!temp))))) + (` (let [(~ g!temp) (~ output)] + (if (not ("lua object nil?" (~ g!temp))) + (~ g!temp) + (.error! "Nil is an invalid value!")))))) + +(type: Import + (#Class [Text Text (List Member)]) + (#Function Static_Method) + (#Constant Field)) + +(def: import + ($_ <>.or + (<>.and <code>.local_identifier + (<>.default ["" (list)] + (<code>.tuple (<>.and <code>.text + (<>.some member))))) + (<code>.form ..common_method) + ..constant + )) + +(def: (with_io with? without) + (-> Bit Code Code) + (if with? + (` (io.io (~ without))) + without)) + +(def: (io_type io? rawT) + (-> Bit Code Code) + (if io? + (` (io.IO (~ rawT))) + rawT)) + +(def: (with_try with? without_try) + (-> Bit Code Code) + (if with? + (` (.try (~ without_try))) + without_try)) + +(def: (try_type try? rawT) + (-> Bit Code Code) + (if try? + (` (.Either .Text (~ rawT))) + rawT)) + +(def: (make_function g!method g!temp source inputsT io? try? outputT) + (-> Code Code Code (List Nilable) Bit Bit Nilable Code) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ g!method) + [(~+ (list\map product.right g!inputs))]) + (-> [(~+ (list\map nilable_type inputsT))] + (~ (|> (nilable_type outputT) + (try_type try?) + (io_type io?)))) + (:assume + (~ (<| (with_io io?) + (with_try try?) + (without_nil g!temp outputT) + (` ("lua apply" + (:as ..Function (~ source)) + (~+ (list\map (with_nil g!temp) g!inputs))))))))))) + +(syntax: #export (import: {import ..import}) + (with_gensyms [g!temp] + (case import + (#Class [class format members]) + (with_gensyms [g!object] + (let [qualify (: (-> Text Code) + (function (_ member_name) + (|> format + (text.replace_all "#" class) + (text.replace_all "." member_name) + code.local_identifier))) + g!type (code.local_identifier class) + real_class (text.replace_all "/" "." class) + imported (case (text.split_all_with "/" class) + (#.Cons head tail) + (list\fold (function (_ sub super) + (` ("lua object get" (~ (code.text sub)) + (:as (..Object .Any) (~ super))))) + (` ("lua import" (~ (code.text head)))) + tail) + + #.Nil + (` ("lua import" (~ (code.text class)))))] + (wrap (list& (` (type: (~ g!type) + (..Object (primitive (~ (code.text real_class)))))) + (list\map (function (_ member) + (case member + (#Field [static? field fieldT]) + (if static? + (` ((~! syntax:) ((~ (qualify field))) + (\ (~! meta.monad) (~' wrap) + (list (` (.:as (~ (nilable_type fieldT)) + ("lua object get" (~ (code.text field)) + (:as (..Object .Any) (~ imported))))))))) + (` (def: ((~ (qualify field)) + (~ g!object)) + (-> (~ g!type) + (~ (nilable_type fieldT))) + (:assume + (~ (without_nil g!temp fieldT (` ("lua object get" (~ (code.text field)) + (:as (..Object .Any) (~ g!object)))))))))) + + (#Method method) + (case method + (#Static [method alias inputsT io? try? outputT]) + (..make_function (qualify (maybe.default method alias)) + g!temp + (` ("lua object get" (~ (code.text method)) + (:as (..Object .Any) (~ imported)))) + inputsT + io? + try? + outputT) + + (#Virtual [method alias inputsT io? try? outputT]) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ (qualify (maybe.default method alias))) + [(~+ (list\map product.right g!inputs))] + (~ g!object)) + (-> [(~+ (list\map nilable_type inputsT))] + (~ g!type) + (~ (|> (nilable_type outputT) + (try_type try?) + (io_type io?)))) + (:assume + (~ (<| (with_io io?) + (with_try try?) + (without_nil g!temp outputT) + (` ("lua object do" + (~ (code.text method)) + (~ g!object) + (~+ (list\map (with_nil g!temp) g!inputs))))))))))))) + members))))) + + (#Function [name alias inputsT io? try? outputT]) + (wrap (list (..make_function (code.local_identifier (maybe.default name alias)) + g!temp + (` ("lua constant" (~ (code.text (text.replace_all "/" "." name))))) + inputsT + io? + try? + outputT))) + + (#Constant [_ name fieldT]) + (wrap (list (` ((~! syntax:) ((~ (code.local_identifier name))) + (\ (~! meta.monad) (~' wrap) + (list (` (.:as (~ (nilable_type fieldT)) + ("lua constant" (~ (code.text (text.replace_all "/" "." name)))))))))))) + ))) + +(template: #export (closure <inputs> <output>) + (.:as ..Function + (`` ("lua function" + (~~ (template.count <inputs>)) + (.function (_ [<inputs>]) + <output>))))) diff --git a/stdlib/source/library/lux/ffi.old.lux b/stdlib/source/library/lux/ffi.old.lux new file mode 100644 index 000000000..fdb5d1412 --- /dev/null +++ b/stdlib/source/library/lux/ffi.old.lux @@ -0,0 +1,1829 @@ +(.module: + [library + [lux (#- type interface:) + ["." type ("#\." equivalence)] + [abstract + ["." monad (#+ Monad do)] + ["." enum]] + [control + ["." function] + ["." io] + ["." try (#+ Try)] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." maybe] + ["." product] + ["." bit ("#\." codec)] + ["." text ("#\." equivalence monoid) + ["%" format (#+ format)]] + [collection + ["." array (#+ Array)] + ["." list ("#\." monad fold monoid)]]] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code]] + ["." meta + ["." annotation]]]]) + +(template [<name> <op> <from> <to>] + [(def: #export (<name> value) + {#.doc (doc "Type converter." + (: <to> + (<name> (: <from> foo))))} + (-> (primitive <from>) (primitive <to>)) + (<op> value))] + + [byte_to_long "jvm convert byte-to-long" "java.lang.Byte" "java.lang.Long"] + + [short_to_long "jvm convert short-to-long" "java.lang.Short" "java.lang.Long"] + + [double_to_int "jvm convert double-to-int" "java.lang.Double" "java.lang.Integer"] + [double_to_long "jvm convert double-to-long" "java.lang.Double" "java.lang.Long"] + [double_to_float "jvm convert double-to-float" "java.lang.Double" "java.lang.Float"] + + [float_to_int "jvm convert float-to-int" "java.lang.Float" "java.lang.Integer"] + [float_to_long "jvm convert float-to-long" "java.lang.Float" "java.lang.Long"] + [float_to_double "jvm convert float-to-double" "java.lang.Float" "java.lang.Double"] + + [int_to_byte "jvm convert int-to-byte" "java.lang.Integer" "java.lang.Byte"] + [int_to_short "jvm convert int-to-short" "java.lang.Integer" "java.lang.Short"] + [int_to_long "jvm convert int-to-long" "java.lang.Integer" "java.lang.Long"] + [int_to_float "jvm convert int-to-float" "java.lang.Integer" "java.lang.Float"] + [int_to_double "jvm convert int-to-double" "java.lang.Integer" "java.lang.Double"] + [int_to_char "jvm convert int-to-char" "java.lang.Integer" "java.lang.Character"] + + [long_to_byte "jvm convert long-to-byte" "java.lang.Long" "java.lang.Byte"] + [long_to_short "jvm convert long-to-short" "java.lang.Long" "java.lang.Short"] + [long_to_int "jvm convert long-to-int" "java.lang.Long" "java.lang.Integer"] + [long_to_float "jvm convert long-to-float" "java.lang.Long" "java.lang.Float"] + [long_to_double "jvm convert long-to-double" "java.lang.Long" "java.lang.Double"] + + [char_to_byte "jvm convert char-to-byte" "java.lang.Character" "java.lang.Byte"] + [char_to_short "jvm convert char-to-short" "java.lang.Character" "java.lang.Short"] + [char_to_int "jvm convert char-to-int" "java.lang.Character" "java.lang.Integer"] + [char_to_long "jvm convert char-to-long" "java.lang.Character" "java.lang.Long"] + ) + +## [Utils] +(def: constructor_method_name "<init>") +(def: member_separator "::") + +## Types +(type: JVM_Code Text) + +(type: BoundKind + #UpperBound + #LowerBound) + +(type: #rec GenericType + (#GenericTypeVar Text) + (#GenericClass [Text (List GenericType)]) + (#GenericArray GenericType) + (#GenericWildcard (Maybe [BoundKind GenericType]))) + +(type: Type_Parameter + [Text (List GenericType)]) + +(type: Primitive_Mode + #ManualPrM + #AutoPrM) + +(type: PrivacyModifier + #PublicPM + #PrivatePM + #ProtectedPM + #DefaultPM) + +(type: StateModifier + #VolatileSM + #FinalSM + #DefaultSM) + +(type: InheritanceModifier + #FinalIM + #AbstractIM + #DefaultIM) + +(type: Class_Kind + #Class + #Interface) + +(type: Class_Declaration + {#class_name Text + #class_params (List Type_Parameter)}) + +(type: StackFrame (primitive "java/lang/StackTraceElement")) +(type: StackTrace (Array StackFrame)) + +(type: Super_Class_Decl + {#super_class_name Text + #super_class_params (List GenericType)}) + +(type: AnnotationParam + [Text Code]) + +(type: Annotation + {#ann_name Text + #ann_params (List AnnotationParam)}) + +(type: Member_Declaration + {#member_name Text + #member_privacy PrivacyModifier + #member_anns (List Annotation)}) + +(type: FieldDecl + (#ConstantField GenericType Code) + (#VariableField StateModifier GenericType)) + +(type: MethodDecl + {#method_tvars (List Type_Parameter) + #method_inputs (List GenericType) + #method_output GenericType + #method_exs (List GenericType)}) + +(type: ArgDecl + {#arg_name Text + #arg_type GenericType}) + +(type: ConstructorArg + [GenericType Code]) + +(type: Method_Definition + (#ConstructorMethod [Bit + (List Type_Parameter) + (List ArgDecl) + (List ConstructorArg) + Code + (List GenericType)]) + (#VirtualMethod [Bit + Bit + (List Type_Parameter) + Text + (List ArgDecl) + GenericType + Code + (List GenericType)]) + (#OverridenMethod [Bit + Class_Declaration + (List Type_Parameter) + Text + (List ArgDecl) + GenericType + Code + (List GenericType)]) + (#StaticMethod [Bit + (List Type_Parameter) + (List ArgDecl) + GenericType + Code + (List GenericType)]) + (#AbstractMethod [(List Type_Parameter) + (List ArgDecl) + GenericType + (List GenericType)]) + (#NativeMethod [(List Type_Parameter) + (List ArgDecl) + GenericType + (List GenericType)])) + +(type: Partial_Call + {#pc_method Name + #pc_args (List Code)}) + +(type: ImportMethodKind + #StaticIMK + #VirtualIMK) + +(type: ImportMethodCommons + {#import_member_mode Primitive_Mode + #import_member_alias Text + #import_member_kind ImportMethodKind + #import_member_tvars (List Type_Parameter) + #import_member_args (List [Bit GenericType]) + #import_member_maybe? Bit + #import_member_try? Bit + #import_member_io? Bit}) + +(type: ImportConstructorDecl + {}) + +(type: ImportMethodDecl + {#import_method_name Text + #import_method_return GenericType}) + +(type: ImportFieldDecl + {#import_field_mode Primitive_Mode + #import_field_name Text + #import_field_static? Bit + #import_field_maybe? Bit + #import_field_setter? Bit + #import_field_type GenericType}) + +(type: Import_Member_Declaration + (#EnumDecl (List Text)) + (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]) + (#MethodDecl [ImportMethodCommons ImportMethodDecl]) + (#FieldAccessDecl ImportFieldDecl)) + +## Utils +(def: (manual_primitive_to_type class) + (-> Text (Maybe Code)) + (case class + (^template [<prim> <type>] + [<prim> + (#.Some (' <type>))]) + (["boolean" (primitive "java.lang.Boolean")] + ["byte" (primitive "java.lang.Byte")] + ["short" (primitive "java.lang.Short")] + ["int" (primitive "java.lang.Integer")] + ["long" (primitive "java.lang.Long")] + ["float" (primitive "java.lang.Float")] + ["double" (primitive "java.lang.Double")] + ["char" (primitive "java.lang.Character")] + ["void" .Any]) + + _ + #.None)) + +(def: (auto_primitive_to_type class) + (-> Text (Maybe Code)) + (case class + (^template [<prim> <type>] + [<prim> + (#.Some (' <type>))]) + (["boolean" .Bit] + ["byte" .Int] + ["short" .Int] + ["int" .Int] + ["long" .Int] + ["float" .Frac] + ["double" .Frac] + ["void" .Any]) + + _ + #.None)) + +(def: sanitize + (-> Text Text) + (text.replace_all "/" ".")) + +(def: (generic_class_to_type' mode type_params in_array? name+params + class_to_type') + (-> Primitive_Mode (List Type_Parameter) Bit [Text (List GenericType)] + (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code) + Code) + (case [name+params mode in_array?] + (^multi [[prim #.Nil] #ManualPrM #0] + [(manual_primitive_to_type prim) (#.Some output)]) + output + + (^multi [[prim #.Nil] #AutoPrM #0] + [(auto_primitive_to_type prim) (#.Some output)]) + output + + [[name params] _ _] + (let [name (sanitize name) + =params (list\map (class_to_type' mode type_params in_array?) params)] + (` (primitive (~ (code.text name)) [(~+ =params)]))))) + +(def: (class_to_type' mode type_params in_array? class) + (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code) + (case class + (#GenericTypeVar name) + (case (list.find (function (_ [pname pbounds]) + (and (text\= name pname) + (not (list.empty? pbounds)))) + type_params) + #.None + (code.identifier ["" name]) + + (#.Some [pname pbounds]) + (class_to_type' mode type_params in_array? (maybe.assume (list.head pbounds)))) + + (#GenericClass name+params) + (generic_class_to_type' mode type_params in_array? name+params + class_to_type') + + (#GenericArray param) + (let [=param (class_to_type' mode type_params #1 param)] + (` ((~! array.Array) (~ =param)))) + + (^or (#GenericWildcard #.None) (#GenericWildcard (#.Some [#LowerBound _]))) + (` .Any) + + (#GenericWildcard (#.Some [#UpperBound upper_bound])) + (class_to_type' mode type_params in_array? upper_bound) + )) + +(def: (class_to_type mode type_params class) + (-> Primitive_Mode (List Type_Parameter) GenericType Code) + (class_to_type' mode type_params #0 class)) + +(def: (type_param_type$ [name bounds]) + (-> Type_Parameter Code) + (code.identifier ["" name])) + +(def: (class_decl_type$ (^slots [#class_name #class_params])) + (-> Class_Declaration Code) + (let [=params (list\map (: (-> Type_Parameter Code) + (function (_ [pname pbounds]) + (case pbounds + #.Nil + (code.identifier ["" pname]) + + (#.Cons bound1 _) + (class_to_type #ManualPrM class_params bound1)))) + class_params)] + (` (primitive (~ (code.text (sanitize class_name))) + [(~+ =params)])))) + +(def: type_var_class Text "java.lang.Object") + +(def: (simple_class$ env class) + (-> (List Type_Parameter) GenericType Text) + (case class + (#GenericTypeVar name) + (case (list.find (function (_ [pname pbounds]) + (and (text\= name pname) + (not (list.empty? pbounds)))) + env) + #.None + type_var_class + + (#.Some [pname pbounds]) + (simple_class$ env (maybe.assume (list.head pbounds)))) + + (^or (#GenericWildcard #.None) (#GenericWildcard (#.Some [#LowerBound _]))) + type_var_class + + (#GenericWildcard (#.Some [#UpperBound upper_bound])) + (simple_class$ env upper_bound) + + (#GenericClass name env) + (sanitize name) + + (#GenericArray param') + (case param' + (#GenericArray param) + (format "[" (simple_class$ env param)) + + (^template [<prim> <class>] + [(#GenericClass <prim> #.Nil) + <class>]) + (["boolean" "[Z"] + ["byte" "[B"] + ["short" "[S"] + ["int" "[I"] + ["long" "[J"] + ["float" "[F"] + ["double" "[D"] + ["char" "[C"]) + + param + (format "[L" (simple_class$ env param) ";")) + )) + +(def: (make_get_const_parser class_name field_name) + (-> Text Text (Parser Code)) + (do <>.monad + [#let [dotted_name (format "::" field_name)] + _ (<code>.this! (code.identifier ["" dotted_name]))] + (wrap (`' ((~ (code.text (format "jvm getstatic" ":" class_name ":" field_name)))))))) + +(def: (make_get_var_parser class_name field_name) + (-> Text Text (Parser Code)) + (do <>.monad + [#let [dotted_name (format "::" field_name)] + _ (<code>.this! (code.identifier ["" dotted_name]))] + (wrap (`' ((~ (code.text (format "jvm getfield" ":" class_name ":" field_name))) _jvm_this))))) + +(def: (make_put_var_parser class_name field_name) + (-> Text Text (Parser Code)) + (do <>.monad + [#let [dotted_name (format "::" field_name)] + [_ _ value] (: (Parser [Any Any Code]) + (<code>.form ($_ <>.and (<code>.this! (' :=)) (<code>.this! (code.identifier ["" dotted_name])) <code>.any)))] + (wrap (`' ((~ (code.text (format "jvm putfield" ":" class_name ":" field_name))) _jvm_this (~ value)))))) + +(def: (pre_walk_replace f input) + (-> (-> Code Code) Code Code) + (case (f input) + (^template [<tag>] + [[meta (<tag> parts)] + [meta (<tag> (list\map (pre_walk_replace f) parts))]]) + ([#.Form] + [#.Tuple]) + + [meta (#.Record pairs)] + [meta (#.Record (list\map (: (-> [Code Code] [Code Code]) + (function (_ [key val]) + [(pre_walk_replace f key) (pre_walk_replace f val)])) + pairs))] + + ast' + ast')) + +(def: (parser->replacer p ast) + (-> (Parser Code) (-> Code Code)) + (case (<>.run p (list ast)) + (#.Right [#.Nil ast']) + ast' + + _ + ast + )) + +(def: (field->parser class_name [[field_name _ _] field]) + (-> Text [Member_Declaration FieldDecl] (Parser Code)) + (case field + (#ConstantField _) + (make_get_const_parser class_name field_name) + + (#VariableField _) + (<>.either (make_get_var_parser class_name field_name) + (make_put_var_parser class_name field_name)))) + +(def: (make_constructor_parser params class_name arg_decls) + (-> (List Type_Parameter) Text (List ArgDecl) (Parser Code)) + (do <>.monad + [args (: (Parser (List Code)) + (<code>.form (<>.after (<code>.this! (' ::new!)) + (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any))))) + #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]] + (wrap (` ((~ (code.text (format "jvm new" ":" class_name ":" (text.join_with "," arg_decls')))) + (~+ args)))))) + +(def: (make_static_method_parser params class_name method_name arg_decls) + (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code)) + (do <>.monad + [#let [dotted_name (format "::" method_name "!")] + args (: (Parser (List Code)) + (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name])) + (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any))))) + #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]] + (wrap (`' ((~ (code.text (format "jvm invokestatic" ":" class_name ":" method_name ":" (text.join_with "," arg_decls')))) + (~+ args)))))) + +(template [<name> <jvm_op>] + [(def: (<name> params class_name method_name arg_decls) + (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code)) + (do <>.monad + [#let [dotted_name (format "::" method_name "!")] + args (: (Parser (List Code)) + (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name])) + (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any))))) + #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]] + (wrap (`' ((~ (code.text (format <jvm_op> ":" class_name ":" method_name ":" (text.join_with "," arg_decls')))) + (~' _jvm_this) (~+ args))))))] + + [make_special_method_parser "jvm invokespecial"] + [make_virtual_method_parser "jvm invokevirtual"] + ) + +(def: (method->parser params class_name [[method_name _ _] meth_def]) + (-> (List Type_Parameter) Text [Member_Declaration Method_Definition] (Parser Code)) + (case meth_def + (#ConstructorMethod strict? type_vars args constructor_args return_expr exs) + (make_constructor_parser params class_name args) + + (#StaticMethod strict? type_vars args return_type return_expr exs) + (make_static_method_parser params class_name method_name args) + + (^or (#VirtualMethod final? strict? type_vars self_name args return_type return_expr exs) + (#OverridenMethod strict? owner_class type_vars self_name args return_type return_expr exs)) + (make_special_method_parser params class_name method_name args) + + (#AbstractMethod type_vars args return_type exs) + (make_virtual_method_parser params class_name method_name args) + + (#NativeMethod type_vars args return_type exs) + (make_virtual_method_parser params class_name method_name args))) + +## Parsers +(def: privacy_modifier^ + (Parser PrivacyModifier) + (let [(^open ".") <>.monad] + ($_ <>.or + (<code>.this! (' #public)) + (<code>.this! (' #private)) + (<code>.this! (' #protected)) + (wrap [])))) + +(def: inheritance_modifier^ + (Parser InheritanceModifier) + (let [(^open ".") <>.monad] + ($_ <>.or + (<code>.this! (' #final)) + (<code>.this! (' #abstract)) + (wrap [])))) + +(def: bound_kind^ + (Parser BoundKind) + (<>.or (<code>.this! (' <)) + (<code>.this! (' >)))) + +(def: (assert_no_periods name) + (-> Text (Parser Any)) + (<>.assert "Names in class declarations cannot contain periods." + (not (text.contains? "." name)))) + +(def: (generic_type^ type_vars) + (-> (List Type_Parameter) (Parser GenericType)) + (<>.rec + (function (_ recur^) + ($_ <>.either + (do <>.monad + [_ (<code>.this! (' ?))] + (wrap (#GenericWildcard #.None))) + (<code>.tuple (do <>.monad + [_ (<code>.this! (' ?)) + bound_kind bound_kind^ + bound recur^] + (wrap (#GenericWildcard (#.Some [bound_kind bound]))))) + (do <>.monad + [name <code>.local_identifier + _ (assert_no_periods name)] + (if (list.member? text.equivalence (list\map product.left type_vars) name) + (wrap (#GenericTypeVar name)) + (wrap (#GenericClass name (list))))) + (<code>.tuple (do <>.monad + [component recur^] + (case component + (^template [<class> <name>] + [(#GenericClass <name> #.Nil) + (wrap (#GenericClass <class> (list)))]) + (["[Z" "boolean"] + ["[B" "byte"] + ["[S" "short"] + ["[I" "int"] + ["[J" "long"] + ["[F" "float"] + ["[D" "double"] + ["[C" "char"]) + + _ + (wrap (#GenericArray component))))) + (<code>.form (do <>.monad + [name <code>.local_identifier + _ (assert_no_periods name) + params (<>.some recur^) + _ (<>.assert (format name " cannot be a type-parameter!") + (not (list.member? text.equivalence (list\map product.left type_vars) name)))] + (wrap (#GenericClass name params)))) + )))) + +(def: type_param^ + (Parser Type_Parameter) + (<>.either (do <>.monad + [param_name <code>.local_identifier] + (wrap [param_name (list)])) + (<code>.tuple (do <>.monad + [param_name <code>.local_identifier + _ (<code>.this! (' <)) + bounds (<>.many (..generic_type^ (list)))] + (wrap [param_name bounds]))))) + +(def: type_params^ + (Parser (List Type_Parameter)) + (|> ..type_param^ + <>.some + <code>.tuple + (<>.default (list)))) + +(def: class_decl^ + (Parser Class_Declaration) + (<>.either (do <>.monad + [name <code>.local_identifier + _ (assert_no_periods name)] + (wrap [name (list)])) + (<code>.form (do <>.monad + [name <code>.local_identifier + _ (assert_no_periods name) + params (<>.some ..type_param^)] + (wrap [name params]))) + )) + +(def: (super_class_decl^ type_vars) + (-> (List Type_Parameter) (Parser Super_Class_Decl)) + (<>.either (do <>.monad + [name <code>.local_identifier + _ (assert_no_periods name)] + (wrap [name (list)])) + (<code>.form (do <>.monad + [name <code>.local_identifier + _ (assert_no_periods name) + params (<>.some (..generic_type^ type_vars))] + (wrap [name params]))))) + +(def: annotation_params^ + (Parser (List AnnotationParam)) + (<code>.record (<>.some (<>.and <code>.local_tag <code>.any)))) + +(def: annotation^ + (Parser Annotation) + (<>.either (do <>.monad + [ann_name <code>.local_identifier] + (wrap [ann_name (list)])) + (<code>.form (<>.and <code>.local_identifier + annotation_params^)))) + +(def: annotations^' + (Parser (List Annotation)) + (do <>.monad + [_ (<code>.this! (' #ann))] + (<code>.tuple (<>.some ..annotation^)))) + +(def: annotations^ + (Parser (List Annotation)) + (do <>.monad + [anns?? (<>.maybe ..annotations^')] + (wrap (maybe.default (list) anns??)))) + +(def: (throws_decl'^ type_vars) + (-> (List Type_Parameter) (Parser (List GenericType))) + (do <>.monad + [_ (<code>.this! (' #throws))] + (<code>.tuple (<>.some (..generic_type^ type_vars))))) + +(def: (throws_decl^ type_vars) + (-> (List Type_Parameter) (Parser (List GenericType))) + (do <>.monad + [exs? (<>.maybe (throws_decl'^ type_vars))] + (wrap (maybe.default (list) exs?)))) + +(def: (method_decl^ type_vars) + (-> (List Type_Parameter) (Parser [Member_Declaration MethodDecl])) + (<code>.form (do <>.monad + [tvars ..type_params^ + name <code>.local_identifier + anns ..annotations^ + inputs (<code>.tuple (<>.some (..generic_type^ type_vars))) + output (..generic_type^ type_vars) + exs (..throws_decl^ type_vars)] + (wrap [[name #PublicPM anns] {#method_tvars tvars + #method_inputs inputs + #method_output output + #method_exs exs}])))) + +(def: state_modifier^ + (Parser StateModifier) + ($_ <>.or + (<code>.this! (' #volatile)) + (<code>.this! (' #final)) + (\ <>.monad wrap []))) + +(def: (field_decl^ type_vars) + (-> (List Type_Parameter) (Parser [Member_Declaration FieldDecl])) + (<>.either (<code>.form (do <>.monad + [_ (<code>.this! (' #const)) + name <code>.local_identifier + anns ..annotations^ + type (..generic_type^ type_vars) + body <code>.any] + (wrap [[name #PublicPM anns] (#ConstantField [type body])]))) + (<code>.form (do <>.monad + [pm privacy_modifier^ + sm state_modifier^ + name <code>.local_identifier + anns ..annotations^ + type (..generic_type^ type_vars)] + (wrap [[name pm anns] (#VariableField [sm type])]))))) + +(def: (arg_decl^ type_vars) + (-> (List Type_Parameter) (Parser ArgDecl)) + (<code>.record (<>.and <code>.local_identifier + (..generic_type^ type_vars)))) + +(def: (arg_decls^ type_vars) + (-> (List Type_Parameter) (Parser (List ArgDecl))) + (<>.some (arg_decl^ type_vars))) + +(def: (constructor_arg^ type_vars) + (-> (List Type_Parameter) (Parser ConstructorArg)) + (<code>.record (<>.and (..generic_type^ type_vars) <code>.any))) + +(def: (constructor_args^ type_vars) + (-> (List Type_Parameter) (Parser (List ConstructorArg))) + (<code>.tuple (<>.some (constructor_arg^ type_vars)))) + +(def: (constructor_method^ class_vars) + (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition])) + (<code>.form (do <>.monad + [pm privacy_modifier^ + strict_fp? (<>.parses? (<code>.this! (' #strict))) + method_vars ..type_params^ + #let [total_vars (list\compose class_vars method_vars)] + [_ arg_decls] (<code>.form (<>.and (<code>.this! (' new)) + (..arg_decls^ total_vars))) + constructor_args (..constructor_args^ total_vars) + exs (..throws_decl^ total_vars) + annotations ..annotations^ + body <code>.any] + (wrap [{#member_name constructor_method_name + #member_privacy pm + #member_anns annotations} + (#ConstructorMethod strict_fp? method_vars arg_decls constructor_args body exs)])))) + +(def: (virtual_method_def^ class_vars) + (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition])) + (<code>.form (do <>.monad + [pm privacy_modifier^ + strict_fp? (<>.parses? (<code>.this! (' #strict))) + final? (<>.parses? (<code>.this! (' #final))) + method_vars ..type_params^ + #let [total_vars (list\compose class_vars method_vars)] + [name this_name arg_decls] (<code>.form ($_ <>.and + <code>.local_identifier + <code>.local_identifier + (..arg_decls^ total_vars))) + return_type (..generic_type^ total_vars) + exs (..throws_decl^ total_vars) + annotations ..annotations^ + body <code>.any] + (wrap [{#member_name name + #member_privacy pm + #member_anns annotations} + (#VirtualMethod final? strict_fp? + method_vars + this_name arg_decls return_type + body exs)])))) + +(def: overriden_method_def^ + (Parser [Member_Declaration Method_Definition]) + (<code>.form (do <>.monad + [strict_fp? (<>.parses? (<code>.this! (' #strict))) + owner_class ..class_decl^ + method_vars ..type_params^ + #let [total_vars (list\compose (product.right owner_class) method_vars)] + [name this_name arg_decls] (<code>.form ($_ <>.and + <code>.local_identifier + <code>.local_identifier + (..arg_decls^ total_vars))) + return_type (..generic_type^ total_vars) + exs (..throws_decl^ total_vars) + annotations ..annotations^ + body <code>.any] + (wrap [{#member_name name + #member_privacy #PublicPM + #member_anns annotations} + (#OverridenMethod strict_fp? + owner_class method_vars + this_name arg_decls return_type + body exs)])))) + +(def: static_method_def^ + (Parser [Member_Declaration Method_Definition]) + (<code>.form (do <>.monad + [pm privacy_modifier^ + strict_fp? (<>.parses? (<code>.this! (' #strict))) + _ (<code>.this! (' #static)) + method_vars ..type_params^ + #let [total_vars method_vars] + [name arg_decls] (<code>.form (<>.and <code>.local_identifier + (..arg_decls^ total_vars))) + return_type (..generic_type^ total_vars) + exs (..throws_decl^ total_vars) + annotations ..annotations^ + body <code>.any] + (wrap [{#member_name name + #member_privacy pm + #member_anns annotations} + (#StaticMethod strict_fp? method_vars arg_decls return_type body exs)])))) + +(def: abstract_method_def^ + (Parser [Member_Declaration Method_Definition]) + (<code>.form (do <>.monad + [pm privacy_modifier^ + _ (<code>.this! (' #abstract)) + method_vars ..type_params^ + #let [total_vars method_vars] + [name arg_decls] (<code>.form (<>.and <code>.local_identifier + (..arg_decls^ total_vars))) + return_type (..generic_type^ total_vars) + exs (..throws_decl^ total_vars) + annotations ..annotations^] + (wrap [{#member_name name + #member_privacy pm + #member_anns annotations} + (#AbstractMethod method_vars arg_decls return_type exs)])))) + +(def: native_method_def^ + (Parser [Member_Declaration Method_Definition]) + (<code>.form (do <>.monad + [pm privacy_modifier^ + _ (<code>.this! (' #native)) + method_vars ..type_params^ + #let [total_vars method_vars] + [name arg_decls] (<code>.form (<>.and <code>.local_identifier + (..arg_decls^ total_vars))) + return_type (..generic_type^ total_vars) + exs (..throws_decl^ total_vars) + annotations ..annotations^] + (wrap [{#member_name name + #member_privacy pm + #member_anns annotations} + (#NativeMethod method_vars arg_decls return_type exs)])))) + +(def: (method_def^ class_vars) + (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition])) + ($_ <>.either + (..constructor_method^ class_vars) + (..virtual_method_def^ class_vars) + ..overriden_method_def^ + ..static_method_def^ + ..abstract_method_def^ + ..native_method_def^)) + +(def: partial_call^ + (Parser Partial_Call) + (<code>.form (<>.and <code>.identifier (<>.some <code>.any)))) + +(def: class_kind^ + (Parser Class_Kind) + (<>.either (do <>.monad + [_ (<code>.this! (' #class))] + (wrap #Class)) + (do <>.monad + [_ (<code>.this! (' #interface))] + (wrap #Interface)) + )) + +(def: import_member_alias^ + (Parser (Maybe Text)) + (<>.maybe (do <>.monad + [_ (<code>.this! (' #as))] + <code>.local_identifier))) + +(def: (import_member_args^ type_vars) + (-> (List Type_Parameter) (Parser (List [Bit GenericType]))) + (<code>.tuple (<>.some (<>.and (<>.parses? (<code>.this! (' #?))) (..generic_type^ type_vars))))) + +(def: import_member_return_flags^ + (Parser [Bit Bit Bit]) + ($_ <>.and (<>.parses? (<code>.this! (' #io))) (<>.parses? (<code>.this! (' #try))) (<>.parses? (<code>.this! (' #?))))) + +(def: primitive_mode^ + (Parser Primitive_Mode) + (<>.or (<code>.this! (' #manual)) + (<code>.this! (' #auto)))) + +(def: (import_member_decl^ owner_vars) + (-> (List Type_Parameter) (Parser Import_Member_Declaration)) + ($_ <>.either + (<code>.form (do <>.monad + [_ (<code>.this! (' #enum)) + enum_members (<>.some <code>.local_identifier)] + (wrap (#EnumDecl enum_members)))) + (<code>.form (do <>.monad + [tvars ..type_params^ + _ (<code>.this! (' new)) + ?alias import_member_alias^ + #let [total_vars (list\compose owner_vars tvars)] + ?prim_mode (<>.maybe primitive_mode^) + args (..import_member_args^ total_vars) + [io? try? maybe?] import_member_return_flags^] + (wrap (#ConstructorDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode) + #import_member_alias (maybe.default "new" ?alias) + #import_member_kind #VirtualIMK + #import_member_tvars tvars + #import_member_args args + #import_member_maybe? maybe? + #import_member_try? try? + #import_member_io? io?} + {}])) + )) + (<code>.form (do <>.monad + [kind (: (Parser ImportMethodKind) + (<>.or (<code>.this! (' #static)) + (wrap []))) + tvars ..type_params^ + name <code>.local_identifier + ?alias import_member_alias^ + #let [total_vars (list\compose owner_vars tvars)] + ?prim_mode (<>.maybe primitive_mode^) + args (..import_member_args^ total_vars) + [io? try? maybe?] import_member_return_flags^ + return (..generic_type^ total_vars)] + (wrap (#MethodDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode) + #import_member_alias (maybe.default name ?alias) + #import_member_kind kind + #import_member_tvars tvars + #import_member_args args + #import_member_maybe? maybe? + #import_member_try? try? + #import_member_io? io?} + {#import_method_name name + #import_method_return return + }])))) + (<code>.form (do <>.monad + [static? (<>.parses? (<code>.this! (' #static))) + name <code>.local_identifier + ?prim_mode (<>.maybe primitive_mode^) + gtype (..generic_type^ owner_vars) + maybe? (<>.parses? (<code>.this! (' #?))) + setter? (<>.parses? (<code>.this! (' #!)))] + (wrap (#FieldAccessDecl {#import_field_mode (maybe.default #AutoPrM ?prim_mode) + #import_field_name name + #import_field_static? static? + #import_field_maybe? maybe? + #import_field_setter? setter? + #import_field_type gtype})))) + )) + +(def: bundle + (-> (List Type_Parameter) (Parser [Text (List Import_Member_Declaration)])) + (|>> ..import_member_decl^ + <>.some + (<>.and <code>.text) + <code>.tuple)) + +## Generators +(def: with_parens + (-> JVM_Code JVM_Code) + (text.enclose ["(" ")"])) + +(def: with_brackets + (-> JVM_Code JVM_Code) + (text.enclose ["[" "]"])) + +(def: spaced + (-> (List JVM_Code) JVM_Code) + (text.join_with " ")) + +(def: (privacy_modifier$ pm) + (-> PrivacyModifier JVM_Code) + (case pm + #PublicPM "public" + #PrivatePM "private" + #ProtectedPM "protected" + #DefaultPM "default")) + +(def: (inheritance_modifier$ im) + (-> InheritanceModifier JVM_Code) + (case im + #FinalIM "final" + #AbstractIM "abstract" + #DefaultIM "default")) + +(def: (annotation_param$ [name value]) + (-> AnnotationParam JVM_Code) + (format name "=" (code.format value))) + +(def: (annotation$ [name params]) + (-> Annotation JVM_Code) + (format "(" name " " "{" (text.join_with text.tab (list\map annotation_param$ params)) "}" ")")) + +(def: (bound_kind$ kind) + (-> BoundKind JVM_Code) + (case kind + #UpperBound "<" + #LowerBound ">")) + +(def: (generic_type$ gtype) + (-> GenericType JVM_Code) + (case gtype + (#GenericTypeVar name) + name + + (#GenericClass name params) + (format "(" (sanitize name) " " (spaced (list\map generic_type$ params)) ")") + + (#GenericArray param) + (format "(" array.type_name " " (generic_type$ param) ")") + + (#GenericWildcard #.None) + "?" + + (#GenericWildcard (#.Some [bound_kind bound])) + (format (bound_kind$ bound_kind) (generic_type$ bound)))) + +(def: (type_param$ [name bounds]) + (-> Type_Parameter JVM_Code) + (format "(" name " " (spaced (list\map generic_type$ bounds)) ")")) + +(def: (class_decl$ (^open ".")) + (-> Class_Declaration JVM_Code) + (format "(" (sanitize class_name) " " (spaced (list\map type_param$ class_params)) ")")) + +(def: (super_class_decl$ (^slots [#super_class_name #super_class_params])) + (-> Super_Class_Decl JVM_Code) + (format "(" (sanitize super_class_name) " " (spaced (list\map generic_type$ super_class_params)) ")")) + +(def: (method_decl$ [[name pm anns] method_decl]) + (-> [Member_Declaration MethodDecl] JVM_Code) + (let [(^slots [#method_tvars #method_inputs #method_output #method_exs]) method_decl] + (with_parens + (spaced (list name + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ method_tvars))) + (with_brackets (spaced (list\map generic_type$ method_exs))) + (with_brackets (spaced (list\map generic_type$ method_inputs))) + (generic_type$ method_output)) + )))) + +(def: (state_modifier$ sm) + (-> StateModifier JVM_Code) + (case sm + #VolatileSM "volatile" + #FinalSM "final" + #DefaultSM "default")) + +(def: (field_decl$ [[name pm anns] field]) + (-> [Member_Declaration FieldDecl] JVM_Code) + (case field + (#ConstantField class value) + (with_parens + (spaced (list "constant" name + (with_brackets (spaced (list\map annotation$ anns))) + (generic_type$ class) + (code.format value)) + )) + + (#VariableField sm class) + (with_parens + (spaced (list "variable" name + (privacy_modifier$ pm) + (state_modifier$ sm) + (with_brackets (spaced (list\map annotation$ anns))) + (generic_type$ class)) + )) + )) + +(def: (arg_decl$ [name type]) + (-> ArgDecl JVM_Code) + (with_parens + (spaced (list name (generic_type$ type))))) + +(def: (constructor_arg$ [class term]) + (-> ConstructorArg JVM_Code) + (with_brackets + (spaced (list (generic_type$ class) (code.format term))))) + +(def: (method_def$ replacer super_class [[name pm anns] method_def]) + (-> (-> Code Code) Super_Class_Decl [Member_Declaration Method_Definition] JVM_Code) + (case method_def + (#ConstructorMethod strict_fp? type_vars arg_decls constructor_args body exs) + (with_parens + (spaced (list "init" + (privacy_modifier$ pm) + (bit\encode strict_fp?) + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ type_vars))) + (with_brackets (spaced (list\map generic_type$ exs))) + (with_brackets (spaced (list\map arg_decl$ arg_decls))) + (with_brackets (spaced (list\map constructor_arg$ constructor_args))) + (code.format (pre_walk_replace replacer body)) + ))) + + (#VirtualMethod final? strict_fp? type_vars this_name arg_decls return_type body exs) + (with_parens + (spaced (list "virtual" + name + (privacy_modifier$ pm) + (bit\encode final?) + (bit\encode strict_fp?) + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ type_vars))) + (with_brackets (spaced (list\map generic_type$ exs))) + (with_brackets (spaced (list\map arg_decl$ arg_decls))) + (generic_type$ return_type) + (code.format (pre_walk_replace replacer (` (let [(~ (code.local_identifier this_name)) (~' _jvm_this)] + (~ body)))))))) + + (#OverridenMethod strict_fp? class_decl type_vars this_name arg_decls return_type body exs) + (let [super_replacer (parser->replacer (<code>.form (do <>.monad + [_ (<code>.this! (' ::super!)) + args (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any)) + #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ (list))) + arg_decls))]] + (wrap (`' ((~ (code.text (format "jvm invokespecial" + ":" (get@ #super_class_name super_class) + ":" name + ":" (text.join_with "," arg_decls')))) + (~' _jvm_this) (~+ args)))))))] + (with_parens + (spaced (list "override" + (class_decl$ class_decl) + name + (bit\encode strict_fp?) + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ type_vars))) + (with_brackets (spaced (list\map generic_type$ exs))) + (with_brackets (spaced (list\map arg_decl$ arg_decls))) + (generic_type$ return_type) + (|> (` (let [(~ (code.local_identifier this_name)) (~' _jvm_this)] + (~ body))) + (pre_walk_replace replacer) + (pre_walk_replace super_replacer) + (code.format)) + )))) + + (#StaticMethod strict_fp? type_vars arg_decls return_type body exs) + (with_parens + (spaced (list "static" + name + (privacy_modifier$ pm) + (bit\encode strict_fp?) + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ type_vars))) + (with_brackets (spaced (list\map generic_type$ exs))) + (with_brackets (spaced (list\map arg_decl$ arg_decls))) + (generic_type$ return_type) + (code.format (pre_walk_replace replacer body))))) + + (#AbstractMethod type_vars arg_decls return_type exs) + (with_parens + (spaced (list "abstract" + name + (privacy_modifier$ pm) + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ type_vars))) + (with_brackets (spaced (list\map generic_type$ exs))) + (with_brackets (spaced (list\map arg_decl$ arg_decls))) + (generic_type$ return_type)))) + + (#NativeMethod type_vars arg_decls return_type exs) + (with_parens + (spaced (list "native" + name + (privacy_modifier$ pm) + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ type_vars))) + (with_brackets (spaced (list\map generic_type$ exs))) + (with_brackets (spaced (list\map arg_decl$ arg_decls))) + (generic_type$ return_type)))) + )) + +(def: (complete_call$ g!obj [method args]) + (-> Code Partial_Call Code) + (` ((~ (code.identifier method)) (~+ args) (~ g!obj)))) + +## [Syntax] +(def: object_super_class + Super_Class_Decl + {#super_class_name "java/lang/Object" + #super_class_params (list)}) + +(syntax: #export (class: + {im inheritance_modifier^} + {class_decl ..class_decl^} + {#let [full_class_name (product.left class_decl)]} + {#let [class_vars (product.right class_decl)]} + {super (<>.default object_super_class + (..super_class_decl^ class_vars))} + {interfaces (<>.default (list) + (<code>.tuple (<>.some (..super_class_decl^ class_vars))))} + {annotations ..annotations^} + {fields (<>.some (..field_decl^ class_vars))} + {methods (<>.some (..method_def^ class_vars))}) + {#.doc (doc "Allows defining JVM classes in Lux code." + "For example:" + (class: #final (TestClass A) [Runnable] + ## Fields + (#private foo boolean) + (#private bar A) + (#private baz java/lang/Object) + ## Methods + (#public [] (new [value A]) [] + (exec (:= ::foo #1) + (:= ::bar value) + (:= ::baz "") + [])) + (#public (virtual) java/lang/Object + "") + (#public #static (static) java/lang/Object + "") + (Runnable [] (run) void + []) + ) + + "The tuple corresponds to parent interfaces." + "An optional super-class can be specified before the tuple. If not specified, java.lang.Object will be assumed." + "Fields and methods defined in the class can be used with special syntax." + "For example:" + "::resolved, for accessing the 'resolved' field." + "(:= ::resolved #1) for modifying it." + "(::new! []) for calling the class's constructor." + "(::resolve! container [value]) for calling the 'resolve' method." + )} + (do meta.monad + [current_module meta.current_module_name + #let [fully_qualified_class_name (format (sanitize current_module) "." full_class_name) + field_parsers (list\map (field->parser fully_qualified_class_name) fields) + method_parsers (list\map (method->parser (product.right class_decl) fully_qualified_class_name) methods) + replacer (parser->replacer (list\fold <>.either + (<>.fail "") + (list\compose field_parsers method_parsers))) + def_code (format "jvm class:" + (spaced (list (class_decl$ class_decl) + (super_class_decl$ super) + (with_brackets (spaced (list\map super_class_decl$ interfaces))) + (inheritance_modifier$ im) + (with_brackets (spaced (list\map annotation$ annotations))) + (with_brackets (spaced (list\map field_decl$ fields))) + (with_brackets (spaced (list\map (method_def$ replacer super) methods))))))]] + (wrap (list (` ((~ (code.text def_code)))))))) + +(syntax: #export (interface: + {class_decl ..class_decl^} + {#let [class_vars (product.right class_decl)]} + {supers (<>.default (list) + (<code>.tuple (<>.some (..super_class_decl^ class_vars))))} + {annotations ..annotations^} + {members (<>.some (..method_decl^ class_vars))}) + {#.doc (doc "Allows defining JVM interfaces." + (interface: TestInterface + ([] foo [boolean String] void #throws [Exception])))} + (let [def_code (format "jvm interface:" + (spaced (list (class_decl$ class_decl) + (with_brackets (spaced (list\map super_class_decl$ supers))) + (with_brackets (spaced (list\map annotation$ annotations))) + (spaced (list\map method_decl$ members)))))] + (wrap (list (` ((~ (code.text def_code)))))) + )) + +(syntax: #export (object + {class_vars (<code>.tuple (<>.some ..type_param^))} + {super (<>.default object_super_class + (..super_class_decl^ class_vars))} + {interfaces (<>.default (list) + (<code>.tuple (<>.some (..super_class_decl^ class_vars))))} + {constructor_args (..constructor_args^ class_vars)} + {methods (<>.some ..overriden_method_def^)}) + {#.doc (doc "Allows defining anonymous classes." + "The 1st tuple corresponds to class-level type-variables." + "The 2nd tuple corresponds to parent interfaces." + "The 3rd tuple corresponds to arguments to the super class constructor." + "An optional super-class can be specified before the 1st tuple. If not specified, java.lang.Object will be assumed." + (object [] [Runnable] + [] + (Runnable [] (run self) void + (exec (do_something some_value) + []))) + )} + (let [def_code (format "jvm anon-class:" + (spaced (list (super_class_decl$ super) + (with_brackets (spaced (list\map super_class_decl$ interfaces))) + (with_brackets (spaced (list\map constructor_arg$ constructor_args))) + (with_brackets (spaced (list\map (method_def$ function.identity super) methods))))))] + (wrap (list (` ((~ (code.text def_code)))))))) + +(syntax: #export (null) + {#.doc (doc "Null object reference." + (null))} + (wrap (list (` ("jvm object null"))))) + +(def: #export (null? obj) + {#.doc (doc "Test for null object reference." + (= (null? (null)) + true) + (= (null? "YOLO") + false))} + (-> (primitive "java.lang.Object") Bit) + ("jvm object null?" obj)) + +(syntax: #export (??? expr) + {#.doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it." + (= (??? (: java/lang/String (null))) + #.None) + (= (??? "YOLO") + (#.Some "YOLO")))} + (with_gensyms [g!temp] + (wrap (list (` (let [(~ g!temp) (~ expr)] + (if ("jvm object null?" (~ g!temp)) + #.None + (#.Some (~ g!temp))))))))) + +(syntax: #export (!!! expr) + {#.doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType." + "A #.None would get translated into a (null)." + (= (null) + (!!! (??? (: java/lang/Thread (null))))) + (= "foo" + (!!! (??? "foo"))))} + (with_gensyms [g!value] + (wrap (list (` ({(#.Some (~ g!value)) + (~ g!value) + + #.None + ("jvm object null")} + (~ expr))))))) + +(syntax: #export (check {class (..generic_type^ (list))} + {unchecked (<>.maybe <code>.any)}) + {#.doc (doc "Checks whether an object is an instance of a particular class." + "Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes." + (case (check java/lang/String "YOLO") + (#.Some value_as_string) + #.None))} + (with_gensyms [g!_ g!unchecked] + (let [class_name (simple_class$ (list) class) + class_type (` (.primitive (~ (code.text class_name)))) + check_type (` (.Maybe (~ class_type))) + check_code (` (if ((~ (code.text (format "jvm instanceof" ":" class_name))) (~ g!unchecked)) + (#.Some (.:as (~ class_type) + (~ g!unchecked))) + #.None))] + (case unchecked + (#.Some unchecked) + (wrap (list (` (: (~ check_type) + (let [(~ g!unchecked) (~ unchecked)] + (~ check_code)))))) + + #.None + (wrap (list (` (: (-> (primitive "java.lang.Object") (~ check_type)) + (function ((~ g!_) (~ g!unchecked)) + (~ check_code)))))) + )))) + +(syntax: #export (synchronized lock body) + {#.doc (doc "Evaluates body, while holding a lock on a given object." + (synchronized object_to_be_locked + (exec (do_something ___) + (do_something_else ___) + (finish_the_computation ___))))} + (wrap (list (` ("jvm object synchronized" (~ lock) (~ body)))))) + +(syntax: #export (do_to obj {methods (<>.some partial_call^)}) + {#.doc (doc "Call a variety of methods on an object. Then, return the object." + (do_to object + (ClassName::method1 arg0 arg1 arg2) + (ClassName::method2 arg3 arg4 arg5)))} + (with_gensyms [g!obj] + (wrap (list (` (let [(~ g!obj) (~ obj)] + (exec (~+ (list\map (complete_call$ g!obj) methods)) + (~ g!obj)))))))) + +(def: (class_import$ [full_name params]) + (-> Class_Declaration Code) + (let [params' (list\map (|>> product.left code.local_identifier) params)] + (` (def: (~ (code.identifier ["" full_name])) + {#..jvm_class (~ (code.text full_name))} + Type + (All [(~+ params')] + (primitive (~ (code.text (sanitize full_name))) + [(~+ params')])))))) + +(def: (member_type_vars class_tvars member) + (-> (List Type_Parameter) Import_Member_Declaration (List Type_Parameter)) + (case member + (#ConstructorDecl [commons _]) + (list\compose class_tvars (get@ #import_member_tvars commons)) + + (#MethodDecl [commons _]) + (case (get@ #import_member_kind commons) + #StaticIMK + (get@ #import_member_tvars commons) + + _ + (list\compose class_tvars (get@ #import_member_tvars commons))) + + _ + class_tvars)) + +(def: (member_def_arg_bindings type_params class member) + (-> (List Type_Parameter) Class_Declaration Import_Member_Declaration (Meta [(List [Bit Code]) (List Text) (List Code)])) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (let [(^slots [#import_member_tvars #import_member_args]) commons] + (do {! meta.monad} + [arg_inputs (monad.map ! + (: (-> [Bit GenericType] (Meta [Bit Code])) + (function (_ [maybe? _]) + (with_gensyms [arg_name] + (wrap [maybe? arg_name])))) + import_member_args) + #let [arg_classes (: (List Text) + (list\map (|>> product.right (simple_class$ (list\compose type_params import_member_tvars))) + import_member_args)) + arg_types (list\map (: (-> [Bit GenericType] Code) + (function (_ [maybe? arg]) + (let [arg_type (class_to_type (get@ #import_member_mode commons) type_params arg)] + (if maybe? + (` (Maybe (~ arg_type))) + arg_type)))) + import_member_args)]] + (wrap [arg_inputs arg_classes arg_types]))) + + _ + (\ meta.monad wrap [(list) (list) (list)]))) + +(def: (decorate_return_maybe class member return_term) + (-> Class_Declaration Import_Member_Declaration Code Code) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (if (get@ #import_member_maybe? commons) + (` (??? (~ return_term))) + (let [g!temp (` ((~' ~') (~ (code.identifier ["" " Ω "]))))] + (` (let [(~ g!temp) (~ return_term)] + (if (not (..null? (:as (primitive "java.lang.Object") + (~ g!temp)))) + (~ g!temp) + (error! (~ (code.text (format "Cannot produce null references from method calls @ " + (get@ #class_name class) + "." (get@ #import_member_alias commons)))))))))) + + _ + return_term)) + +(template [<name> <tag> <term_trans>] + [(def: (<name> member return_term) + (-> Import_Member_Declaration Code Code) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (if (get@ <tag> commons) + <term_trans> + return_term) + + _ + return_term))] + + [decorate_return_try #import_member_try? (` (.try (~ return_term)))] + [decorate_return_io #import_member_io? (` ((~! io.io) (~ return_term)))] + ) + +(def: (free_type_param? [name bounds]) + (-> Type_Parameter Bit) + (case bounds + #.Nil #1 + _ #0)) + +(def: (type_param->type_arg [name _]) + (-> Type_Parameter Code) + (code.identifier ["" name])) + +(template [<name> <byte> <short> <int> <float>] + [(def: (<name> mode [class expression]) + (-> Primitive_Mode [Text Code] Code) + (case mode + #ManualPrM + expression + + #AutoPrM + (case class + "byte" (` (<byte> (~ expression))) + "short" (` (<short> (~ expression))) + "int" (` (<int> (~ expression))) + "float" (` (<float> (~ expression))) + _ expression)))] + + [auto_convert_input long_to_byte long_to_short long_to_int double_to_float] + [auto_convert_output byte_to_long short_to_long int_to_long float_to_double] + ) + +(def: (un_quote quoted) + (-> Code Code) + (` ((~' ~) (~ quoted)))) + +(def: (jvm_extension_inputs mode classes inputs) + (-> Primitive_Mode (List Text) (List [Bit Code]) (List Code)) + (|> inputs + (list\map (function (_ [maybe? input]) + (if maybe? + (` ((~! !!!) (~ (un_quote input)))) + (un_quote input)))) + (list.zip/2 classes) + (list\map (auto_convert_input mode)))) + +(def: (import_name format class member) + (-> Text Text Text Text) + (|> format + (text.replace_all "#" class) + (text.replace_all "." member))) + +(def: (member_def_interop type_params kind class [arg_function_inputs arg_classes arg_types] member method_prefix import_format) + (-> (List Type_Parameter) Class_Kind Class_Declaration [(List [Bit Code]) (List Text) (List Code)] Import_Member_Declaration Text Text (Meta (List Code))) + (let [[full_name class_tvars] class + full_name (sanitize full_name) + all_params (|> (member_type_vars class_tvars member) + (list.filter free_type_param?) + (list\map type_param->type_arg))] + (case member + (#EnumDecl enum_members) + (do {! meta.monad} + [#let [enum_type (: Code + (case class_tvars + #.Nil + (` (primitive (~ (code.text full_name)))) + + _ + (let [=class_tvars (|> class_tvars + (list.filter free_type_param?) + (list\map type_param->type_arg))] + (` (All [(~+ =class_tvars)] (primitive (~ (code.text full_name)) [(~+ =class_tvars)])))))) + getter_interop (: (-> Text Code) + (function (_ name) + (let [getter_name (code.identifier ["" (..import_name import_format method_prefix name)])] + (` (def: (~ getter_name) + (~ enum_type) + ((~ (code.text (format "jvm getstatic" ":" full_name ":" name)))))))))]] + (wrap (list\map getter_interop enum_members))) + + (#ConstructorDecl [commons _]) + (do meta.monad + [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))]) + jvm_extension (code.text (format "jvm new" ":" full_name ":" (text.join_with "," arg_classes))) + jvm_interop (|> (` ((~ jvm_extension) + (~+ (jvm_extension_inputs (get@ #import_member_mode commons) arg_classes arg_function_inputs)))) + (decorate_return_maybe class member) + (decorate_return_try member) + (decorate_return_io member))]] + (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs))) + ((~' wrap) (.list (.` (~ jvm_interop))))))))) + + (#MethodDecl [commons method]) + (with_gensyms [g!obj] + (do meta.monad + [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))]) + (^slots [#import_member_kind]) commons + (^slots [#import_method_name]) method + [jvm_op object_ast] (: [Text (List Code)] + (case import_member_kind + #StaticIMK + ["invokestatic" + (list)] + + #VirtualIMK + (case kind + #Class + ["invokevirtual" + (list g!obj)] + + #Interface + ["invokeinterface" + (list g!obj)] + ))) + jvm_extension (code.text (format "jvm " jvm_op ":" full_name ":" import_method_name ":" (text.join_with "," arg_classes))) + jvm_interop (|> [(simple_class$ (list) (get@ #import_method_return method)) + (` ((~ jvm_extension) (~+ (list\map un_quote object_ast)) + (~+ (jvm_extension_inputs (get@ #import_member_mode commons) arg_classes arg_function_inputs))))] + (auto_convert_output (get@ #import_member_mode commons)) + (decorate_return_maybe class member) + (decorate_return_try member) + (decorate_return_io member))]] + (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs)) (~+ object_ast)) + ((~' wrap) (.list (.` (~ jvm_interop)))))))))) + + (#FieldAccessDecl fad) + (do meta.monad + [#let [(^open ".") fad + base_gtype (class_to_type import_field_mode type_params import_field_type) + classC (class_decl_type$ class) + typeC (if import_field_maybe? + (` (Maybe (~ base_gtype))) + base_gtype) + tvar_asts (: (List Code) + (|> class_tvars + (list.filter free_type_param?) + (list\map type_param->type_arg))) + getter_name (code.identifier ["" (..import_name import_format method_prefix import_field_name)]) + setter_name (code.identifier ["" (..import_name import_format method_prefix (format import_field_name "!"))])] + getter_interop (with_gensyms [g!obj] + (let [getter_call (if import_field_static? + (` ((~ getter_name))) + (` ((~ getter_name) (~ g!obj)))) + getter_body (<| (auto_convert_output import_field_mode) + [(simple_class$ (list) import_field_type) + (if import_field_static? + (let [jvm_extension (code.text (format "jvm getstatic" ":" full_name ":" import_field_name))] + (` ((~ jvm_extension)))) + (let [jvm_extension (code.text (format "jvm getfield" ":" full_name ":" import_field_name))] + (` ((~ jvm_extension) (~ (un_quote g!obj))))))]) + getter_body (if import_field_maybe? + (` ((~! ???) (~ getter_body))) + getter_body) + getter_body (if import_field_setter? + (` ((~! io.io) (~ getter_body))) + getter_body)] + (wrap (` ((~! syntax:) (~ getter_call) + ((~' wrap) (.list (.` (~ getter_body))))))))) + setter_interop (: (Meta (List Code)) + (if import_field_setter? + (with_gensyms [g!obj g!value] + (let [setter_call (if import_field_static? + (` ((~ setter_name) (~ g!value))) + (` ((~ setter_name) (~ g!value) (~ g!obj)))) + setter_value (auto_convert_input import_field_mode + [(simple_class$ (list) import_field_type) (un_quote g!value)]) + setter_value (if import_field_maybe? + (` ((~! !!!) (~ setter_value))) + setter_value) + setter_command (format (if import_field_static? "jvm putstatic" "jvm putfield") + ":" full_name ":" import_field_name) + g!obj+ (: (List Code) + (if import_field_static? + (list) + (list (un_quote g!obj))))] + (wrap (list (` ((~! syntax:) (~ setter_call) + ((~' wrap) (.list (.` ((~! io.io) ((~ (code.text setter_command)) (~+ g!obj+) (~ setter_value)))))))))))) + (wrap (list))))] + (wrap (list& getter_interop setter_interop))) + ))) + +(def: (member_import$ type_params kind class [import_format member]) + (-> (List Type_Parameter) Class_Kind Class_Declaration [Text Import_Member_Declaration] (Meta (List Code))) + (let [[method_prefix _] class] + (do meta.monad + [=args (member_def_arg_bindings type_params class member)] + (member_def_interop type_params kind class =args member method_prefix import_format)))) + +(type: (java/lang/Class a) + (primitive "java.lang.Class" [a])) + +(def: interface? + (All [a] (-> (java/lang/Class a) Bit)) + (|>> "jvm invokevirtual:java.lang.Class:isInterface:")) + +(def: (load_class class_name) + (-> Text (Try (java/lang/Class Any))) + (try ("jvm invokestatic:java.lang.Class:forName:java.lang.String" class_name))) + +(def: (class_kind [class_name _]) + (-> Class_Declaration (Meta Class_Kind)) + (let [class_name (..sanitize class_name)] + (case (..load_class class_name) + (#try.Success class) + (\ meta.monad wrap (if (interface? class) + #Interface + #Class)) + + (#try.Failure error) + (meta.fail (format "Cannot load class: " class_name text.new_line + error))))) + +(syntax: #export (import: + {class_decl ..class_decl^} + {bundles (<>.some (..bundle (product.right class_decl)))}) + {#.doc (doc "Allows importing JVM classes, and using them as types." + "Their methods, fields and enum options can also be imported." + (import: java/lang/Object + ["#::." + (new []) + (equals [java/lang/Object] boolean) + (wait [int] #io #try void)]) + + "Special options can also be given for the return values." + "#? means that the values will be returned inside a Maybe type. That way, null becomes #.None." + "#try means that the computation might throw an exception, and the return value will be wrapped by the Try type." + "#io means the computation has side effects, and will be wrapped by the IO type." + "These options must show up in the following order [#io #try #?] (although, each option can be used independently)." + (import: java/lang/String + ["#::." + (new [[byte]]) + (#static valueOf [char] java/lang/String) + (#static valueOf #as int_valueOf [int] java/lang/String)]) + + (import: (java/util/List e) + ["#::." + (size [] int) + (get [int] e)]) + + (import: (java/util/ArrayList a) + ["#::." + ([T] toArray [[T]] [T])]) + + "The class-type that is generated is of the fully-qualified name." + "This avoids a clash between the java.util.List type, and Lux's own List type." + "All enum options to be imported must be specified." + (import: java/lang/Character$UnicodeScript + ["#::." + (#enum ARABIC CYRILLIC LATIN)]) + + "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-parameters." + "Lux types, such as Maybe cannot be named (otherwise, they'd be confused for Java classes)." + (import: (lux/concurrency/promise/JvmPromise A) + ["#::." + (resolve [A] boolean) + (poll [] A) + (wasResolved [] boolean) + (waitOn [lux/Function] void) + (#static [A] make [A] (lux/concurrency/promise/JvmPromise A))]) + + "Also, the names of the imported members will look like Class::member" + (java/lang/Object::new []) + (java/lang/Object::equals [other_object] my_object) + (java/util/List::size [] my_list) + java/lang/Character$UnicodeScript::LATIN + )} + (do {! meta.monad} + [kind (class_kind class_decl) + =members (|> bundles + (list\map (function (_ [import_format members]) + (list\map (|>> [import_format]) members))) + list.concat + (monad.map ! (member_import$ (product.right class_decl) kind class_decl)))] + (wrap (list& (class_import$ class_decl) (list\join =members))))) + +(syntax: #export (array {type (..generic_type^ (list))} + size) + {#.doc (doc "Create an array of the given type, with the given size." + (array java/lang/Object 10))} + (case type + (^template [<type> <array_op>] + [(^ (#GenericClass <type> (list))) + (wrap (list (` (<array_op> (~ size)))))]) + (["boolean" "jvm znewarray"] + ["byte" "jvm bnewarray"] + ["short" "jvm snewarray"] + ["int" "jvm inewarray"] + ["long" "jvm lnewarray"] + ["float" "jvm fnewarray"] + ["double" "jvm dnewarray"] + ["char" "jvm cnewarray"]) + + _ + (wrap (list (` ("jvm anewarray" (~ (code.text (generic_type$ type))) (~ size))))))) + +(syntax: #export (array_length array) + {#.doc (doc "Gives the length of an array." + (array_length my_array))} + (wrap (list (` ("jvm arraylength" (~ array)))))) + +(def: (type->class_name type) + (-> Type (Meta Text)) + (if (type\= Any type) + (\ meta.monad wrap "java.lang.Object") + (case type + (#.Primitive name params) + (\ meta.monad wrap name) + + (#.Apply A F) + (case (type.apply (list A) F) + #.None + (meta.fail (format "Cannot apply type: " (type.format F) " to " (type.format A))) + + (#.Some type') + (type->class_name type')) + + (#.Named _ type') + (type->class_name type') + + _ + (meta.fail (format "Cannot convert to JvmType: " (type.format type)))))) + +(syntax: #export (array_read idx array) + {#.doc (doc "Loads an element from an array." + (array_read 10 my_array))} + (case array + [_ (#.Identifier array_name)] + (do meta.monad + [array_type (meta.find_type array_name) + array_jvm_type (type->class_name array_type)] + (case array_jvm_type + (^template [<type> <array_op>] + [<type> + (wrap (list (` (<array_op> (~ array) (~ idx)))))]) + (["[Z" "jvm zaload"] + ["[B" "jvm baload"] + ["[S" "jvm saload"] + ["[I" "jvm iaload"] + ["[J" "jvm jaload"] + ["[F" "jvm faload"] + ["[D" "jvm daload"] + ["[C" "jvm caload"]) + + _ + (wrap (list (` ("jvm aaload" (~ array) (~ idx))))))) + + _ + (with_gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (..array_read (~ idx) (~ g!array))))))))) + +(syntax: #export (array_write idx value array) + {#.doc (doc "Stores an element into an array." + (array_write 10 my_object my_array))} + (case array + [_ (#.Identifier array_name)] + (do meta.monad + [array_type (meta.find_type array_name) + array_jvm_type (type->class_name array_type)] + (case array_jvm_type + (^template [<type> <array_op>] + [<type> + (wrap (list (` (<array_op> (~ array) (~ idx) (~ value)))))]) + (["[Z" "jvm zastore"] + ["[B" "jvm bastore"] + ["[S" "jvm sastore"] + ["[I" "jvm iastore"] + ["[J" "jvm jastore"] + ["[F" "jvm fastore"] + ["[D" "jvm dastore"] + ["[C" "jvm castore"]) + + _ + (wrap (list (` ("jvm aastore" (~ array) (~ idx) (~ value))))))) + + _ + (with_gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (..array_write (~ idx) (~ value) (~ g!array))))))))) + +(syntax: #export (class_for {type (..generic_type^ (list))}) + {#.doc (doc "Loads the class as a java.lang.Class object." + (class_for java/lang/String))} + (wrap (list (` ("jvm object class" (~ (code.text (simple_class$ (list) type)))))))) + +(syntax: #export (type {type (..generic_type^ (list))}) + (wrap (list (..class_to_type #ManualPrM (list) type)))) diff --git a/stdlib/source/library/lux/ffi.php.lux b/stdlib/source/library/lux/ffi.php.lux new file mode 100644 index 000000000..eb9b5fbed --- /dev/null +++ b/stdlib/source/library/lux/ffi.php.lux @@ -0,0 +1,314 @@ +(.module: + [library + [lux (#- Alias) + ["." meta] + ["@" target] + [abstract + [monad (#+ do)]] + [control + ["." io] + ["<>" parser ("#\." monad) + ["<.>" code (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text + ["%" format]] + [collection + ["." list ("#\." functor fold)]]] + [type + abstract] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code] + ["." template]]]]) + +(abstract: #export (Object brand) Any) + +(template [<name>] + [(with_expansions [<brand> (template.identifier [<name> "'"])] + (abstract: #export <brand> Any) + (type: #export <name> + (..Object <brand>)))] + + [Null] + [Function] + ) + +(template [<name> <type>] + [(type: #export <name> + <type>)] + + [Boolean Bit] + [Integer Int] + [Float Frac] + [String Text] + ) + +(type: Nullable + [Bit Code]) + +(def: nullable + (Parser Nullable) + (let [token (' #?)] + (<| (<>.and (<>.parses? (<code>.this! token))) + (<>.after (<>.not (<code>.this! token))) + <code>.any))) + +(type: Alias + Text) + +(def: alias + (Parser Alias) + (<>.after (<code>.this! (' #as)) <code>.local_identifier)) + +(type: Field + [Bit Text (Maybe Alias) Nullable]) + +(def: static! + (Parser Any) + (<code>.this! (' #static))) + +(def: field + (Parser Field) + (<code>.form ($_ <>.and + (<>.parses? ..static!) + <code>.local_identifier + (<>.maybe ..alias) + ..nullable))) + +(def: constant + (Parser Field) + (<code>.form ($_ <>.and + (<>\wrap true) + <code>.local_identifier + (<>.maybe ..alias) + ..nullable))) + +(type: Common_Method + {#name Text + #alias (Maybe Alias) + #inputs (List Nullable) + #io? Bit + #try? Bit + #output Nullable}) + +(type: Static_Method Common_Method) +(type: Virtual_Method Common_Method) + +(type: Method + (#Static Static_Method) + (#Virtual Virtual_Method)) + +(def: common_method + (Parser Common_Method) + ($_ <>.and + <code>.local_identifier + (<>.maybe ..alias) + (<code>.tuple (<>.some ..nullable)) + (<>.parses? (<code>.this! (' #io))) + (<>.parses? (<code>.this! (' #try))) + ..nullable)) + +(def: static_method + (<>.after ..static! ..common_method)) + +(def: method + (Parser Method) + (<code>.form (<>.or ..static_method + ..common_method))) + +(type: Member + (#Field Field) + (#Method Method)) + +(def: member + (Parser Member) + ($_ <>.or + ..field + ..method + )) + +(def: input_variables + (-> (List Nullable) (List [Bit Code])) + (|>> list.enumeration + (list\map (function (_ [idx [nullable? type]]) + [nullable? (|> idx %.nat code.local_identifier)])))) + +(def: (nullable_type [nullable? type]) + (-> Nullable Code) + (if nullable? + (` (.Maybe (~ type))) + type)) + +(def: (with_null g!temp [nullable? input]) + (-> Code [Bit Code] Code) + (if nullable? + (` (case (~ input) + (#.Some (~ g!temp)) + (~ g!temp) + + #.Null + ("php object null"))) + input)) + +(def: (without_null g!temp [nullable? outputT] output) + (-> Code Nullable Code Code) + (if nullable? + (` (let [(~ g!temp) (~ output)] + (if ("php object null?" (~ g!temp)) + #.None + (#.Some (~ g!temp))))) + (` (let [(~ g!temp) (~ output)] + (if (not ("php object null?" (~ g!temp))) + (~ g!temp) + (.error! "Null is an invalid value!")))))) + +(type: Import + (#Class Text (Maybe Alias) Text (List Member)) + (#Function Static_Method) + (#Constant Field)) + +(def: import + (Parser Import) + ($_ <>.or + ($_ <>.and + <code>.local_identifier + (<>.maybe ..alias) + (<>.default ["" (list)] + (<code>.tuple (<>.and <code>.text + (<>.some member))))) + (<code>.form ..common_method) + ..constant + )) + +(syntax: #export (try expression) + {#.doc (doc (case (try (risky_computation input)) + (#.Right success) + (do_something success) + + (#.Left error) + (recover_from_failure error)))} + (wrap (list (` ("lux try" ((~! io.io) (~ expression))))))) + +(def: (with_io with? without) + (-> Bit Code Code) + (if with? + (` (io.io (~ without))) + without)) + +(def: (io_type io? rawT) + (-> Bit Code Code) + (if io? + (` (io.IO (~ rawT))) + rawT)) + +(def: (with_try with? without_try) + (-> Bit Code Code) + (if with? + (` (..try (~ without_try))) + without_try)) + +(def: (try_type try? rawT) + (-> Bit Code Code) + (if try? + (` (.Either .Text (~ rawT))) + rawT)) + +(def: (make_function g!method g!temp source inputsT io? try? outputT) + (-> Code Code Code (List Nullable) Bit Bit Nullable Code) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ g!method) + [(~+ (list\map product.right g!inputs))]) + (-> [(~+ (list\map nullable_type inputsT))] + (~ (|> (nullable_type outputT) + (try_type try?) + (io_type io?)))) + (:assume + (~ (<| (with_io io?) + (with_try try?) + (without_null g!temp outputT) + (` ("php apply" + (:as ..Function (~ source)) + (~+ (list\map (with_null g!temp) g!inputs))))))))))) + +(syntax: #export (import: {import ..import}) + (with_gensyms [g!temp] + (case import + (#Class [class alias format members]) + (with_gensyms [g!object] + (let [qualify (: (-> Text Code) + (function (_ member_name) + (|> format + (text.replace_all "#" (maybe.default class alias)) + (text.replace_all "." member_name) + code.local_identifier))) + g!type (code.local_identifier (maybe.default class alias)) + class_import (` ("php constant" (~ (code.text class))))] + (wrap (list& (` (type: (~ g!type) + (..Object (primitive (~ (code.text class)))))) + (list\map (function (_ member) + (case member + (#Field [static? field alias fieldT]) + (if static? + (` ((~! syntax:) ((~ (qualify (maybe.default field alias)))) + (\ (~! meta.monad) (~' wrap) + (list (` (.:as (~ (nullable_type fieldT)) + ("php constant" (~ (code.text (%.format class "::" field)))))))))) + (` (def: ((~ (qualify field)) + (~ g!object)) + (-> (~ g!type) + (~ (nullable_type fieldT))) + (:assume + (~ (without_null g!temp fieldT (` ("php object get" (~ (code.text field)) + (:as (..Object .Any) (~ g!object)))))))))) + + (#Method method) + (case method + (#Static [method alias inputsT io? try? outputT]) + (..make_function (qualify (maybe.default method alias)) + g!temp + (` ("php object get" (~ (code.text method)) + (:as (..Object .Any) + ("php constant" (~ (code.text (%.format class "::" method))))))) + inputsT + io? + try? + outputT) + + (#Virtual [method alias inputsT io? try? outputT]) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ (qualify (maybe.default method alias))) + [(~+ (list\map product.right g!inputs))] + (~ g!object)) + (-> [(~+ (list\map nullable_type inputsT))] + (~ g!type) + (~ (|> (nullable_type outputT) + (try_type try?) + (io_type io?)))) + (:assume + (~ (<| (with_io io?) + (with_try try?) + (without_null g!temp outputT) + (` ("php object do" + (~ (code.text method)) + (~ g!object) + (~+ (list\map (with_null g!temp) g!inputs))))))))))))) + members))))) + + (#Function [name alias inputsT io? try? outputT]) + (let [imported (` ("php constant" (~ (code.text name))))] + (wrap (list (..make_function (code.local_identifier (maybe.default name alias)) + g!temp + imported + inputsT + io? + try? + outputT)))) + + (#Constant [_ name alias fieldT]) + (let [imported (` ("php constant" (~ (code.text name))))] + (wrap (list (` ((~! syntax:) ((~ (code.local_identifier (maybe.default name alias)))) + (\ (~! meta.monad) (~' wrap) + (list (` (.:as (~ (nullable_type fieldT)) (~ imported)))))))))) + ))) diff --git a/stdlib/source/library/lux/ffi.py.lux b/stdlib/source/library/lux/ffi.py.lux new file mode 100644 index 000000000..737cfefd8 --- /dev/null +++ b/stdlib/source/library/lux/ffi.py.lux @@ -0,0 +1,315 @@ +(.module: + [library + [lux #* + ["." meta] + ["@" target] + [abstract + [monad (#+ do)]] + [control + ["." io] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text + ["%" format]] + [collection + ["." list ("#\." functor fold)]]] + [type + abstract] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code] + ["." template]]]]) + +(abstract: #export (Object brand) Any) + +(template [<name>] + [(with_expansions [<brand> (template.identifier [<name> "'"])] + (abstract: <brand> Any) + (type: #export <name> + (..Object <brand>)))] + + [None] + [Dict] + [Function] + ) + +(template [<name> <type>] + [(type: #export <name> + <type>)] + + [Boolean Bit] + [Integer Int] + [Float Frac] + [String Text] + ) + +(type: Noneable + [Bit Code]) + +(def: noneable + (Parser Noneable) + (let [token (' #?)] + (<| (<>.and (<>.parses? (<code>.this! token))) + (<>.after (<>.not (<code>.this! token))) + <code>.any))) + +(type: Constructor + (List Noneable)) + +(def: constructor + (Parser Constructor) + (<code>.form (<>.after (<code>.this! (' new)) + (<code>.tuple (<>.some ..noneable))))) + +(type: Field + [Bit Text Noneable]) + +(def: static! + (Parser Any) + (<code>.this! (' #static))) + +(def: field + (Parser Field) + (<code>.form ($_ <>.and + (<>.parses? ..static!) + <code>.local_identifier + ..noneable))) + +(type: Common_Method + {#name Text + #alias (Maybe Text) + #inputs (List Noneable) + #io? Bit + #try? Bit + #output Noneable}) + +(type: Static_Method Common_Method) +(type: Virtual_Method Common_Method) + +(type: Method + (#Static Static_Method) + (#Virtual Virtual_Method)) + +(def: common_method + (Parser Common_Method) + ($_ <>.and + <code>.local_identifier + (<>.maybe (<>.after (<code>.this! (' #as)) <code>.local_identifier)) + (<code>.tuple (<>.some ..noneable)) + (<>.parses? (<code>.this! (' #io))) + (<>.parses? (<code>.this! (' #try))) + ..noneable)) + +(def: static_method + (<>.after ..static! ..common_method)) + +(def: method + (Parser Method) + (<code>.form (<>.or ..static_method + ..common_method))) + +(type: Member + (#Constructor Constructor) + (#Field Field) + (#Method Method)) + +(def: member + (Parser Member) + ($_ <>.or + ..constructor + ..field + ..method + )) + +(def: input_variables + (-> (List Noneable) (List [Bit Code])) + (|>> list.enumeration + (list\map (function (_ [idx [noneable? type]]) + [noneable? (|> idx %.nat code.local_identifier)])))) + +(def: (noneable_type [noneable? type]) + (-> Noneable Code) + (if noneable? + (` (.Maybe (~ type))) + type)) + +(def: (with_none g!temp [noneable? input]) + (-> Code [Bit Code] Code) + (if noneable? + (` (case (~ input) + (#.Some (~ g!temp)) + (~ g!temp) + + #.None + ("python object none"))) + input)) + +(def: (without_none g!temp [noneable? outputT] output) + (-> Code Noneable Code Code) + (if noneable? + (` (let [(~ g!temp) (~ output)] + (if ("python object none?" (~ g!temp)) + #.None + (#.Some (~ g!temp))))) + (` (let [(~ g!temp) (~ output)] + (if (not ("python object none?" (~ g!temp))) + (~ g!temp) + (.error! "None is an invalid value!")))))) + +(type: Import + (#Class [Text Text (List Member)]) + (#Function Static_Method)) + +(def: import + (Parser Import) + (<>.or (<>.and <code>.local_identifier + (<>.default ["" (list)] + (<code>.tuple (<>.and <code>.text + (<>.some member))))) + (<code>.form ..common_method))) + +(def: (with_io with? without) + (-> Bit Code Code) + (if with? + (` (io.io (~ without))) + without)) + +(def: (io_type io? rawT) + (-> Bit Code Code) + (if io? + (` (io.IO (~ rawT))) + rawT)) + +(def: (with_try with? without_try) + (-> Bit Code Code) + (if with? + (` (.try (~ without_try))) + without_try)) + +(def: (try_type try? rawT) + (-> Bit Code Code) + (if try? + (` (.Either .Text (~ rawT))) + rawT)) + +(def: (make_function g!method g!temp source inputsT io? try? outputT) + (-> Code Code Code (List Noneable) Bit Bit Noneable Code) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ g!method) + [(~+ (list\map product.right g!inputs))]) + (-> [(~+ (list\map noneable_type inputsT))] + (~ (|> (noneable_type outputT) + (try_type try?) + (io_type io?)))) + (:assume + (~ (<| (with_io io?) + (with_try try?) + (without_none g!temp outputT) + (` ("python apply" + (:as ..Function (~ source)) + (~+ (list\map (with_none g!temp) g!inputs))))))))))) + +(syntax: #export (import: {import ..import}) + (with_gensyms [g!temp] + (case import + (#Class [class format members]) + (with_gensyms [g!object] + (let [qualify (: (-> Text Code) + (function (_ member_name) + (|> format + (text.replace_all "#" class) + (text.replace_all "." member_name) + code.local_identifier))) + g!type (code.local_identifier class) + real_class (text.replace_all "/" "." class) + imported (case (text.split_all_with "/" class) + (#.Cons head tail) + (list\fold (function (_ sub super) + (` ("python object get" (~ (code.text sub)) + (:as (..Object .Any) (~ super))))) + (` ("python import" (~ (code.text head)))) + tail) + + #.Nil + (` ("python import" (~ (code.text class)))))] + (wrap (list& (` (type: (~ g!type) + (..Object (primitive (~ (code.text real_class)))))) + (list\map (function (_ member) + (case member + (#Constructor inputsT) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ (qualify "new")) + [(~+ (list\map product.right g!inputs))]) + (-> [(~+ (list\map noneable_type inputsT))] + (~ g!type)) + (:assume + ("python apply" + (:as ..Function (~ imported)) + (~+ (list\map (with_none g!temp) g!inputs))))))) + + (#Field [static? field fieldT]) + (if static? + (` ((~! syntax:) ((~ (qualify field))) + (\ (~! meta.monad) (~' wrap) + (list (` (.:as (~ (noneable_type fieldT)) + ("python object get" (~ (code.text field)) + (:as (..Object .Any) (~ imported))))))))) + (` (def: ((~ (qualify field)) + (~ g!object)) + (-> (~ g!type) + (~ (noneable_type fieldT))) + (:assume + (~ (without_none g!temp fieldT (` ("python object get" (~ (code.text field)) + (:as (..Object .Any) (~ g!object)))))))))) + + (#Method method) + (case method + (#Static [method alias inputsT io? try? outputT]) + (..make_function (qualify (maybe.default method alias)) + g!temp + (` ("python object get" (~ (code.text method)) + (:as (..Object .Any) (~ imported)))) + inputsT + io? + try? + outputT) + + (#Virtual [method alias inputsT io? try? outputT]) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ (qualify (maybe.default method alias))) + [(~+ (list\map product.right g!inputs))] + (~ g!object)) + (-> [(~+ (list\map noneable_type inputsT))] + (~ g!type) + (~ (|> (noneable_type outputT) + (try_type try?) + (io_type io?)))) + (:assume + (~ (<| (with_io io?) + (with_try try?) + (without_none g!temp outputT) + (` ("python object do" + (~ (code.text method)) + (~ g!object) + (~+ (list\map (with_none g!temp) g!inputs))))))))))))) + members))))) + + (#Function [name alias inputsT io? try? outputT]) + (wrap (list (..make_function (code.local_identifier (maybe.default name alias)) + g!temp + (` ("python constant" (~ (code.text name)))) + inputsT + io? + try? + outputT))) + ))) + +(template: #export (lambda <inputs> <output>) + (.:as ..Function + (`` ("python function" + (~~ (template.count <inputs>)) + (.function (_ [<inputs>]) + <output>))))) diff --git a/stdlib/source/library/lux/ffi.rb.lux b/stdlib/source/library/lux/ffi.rb.lux new file mode 100644 index 000000000..511351bad --- /dev/null +++ b/stdlib/source/library/lux/ffi.rb.lux @@ -0,0 +1,332 @@ +(.module: + [library + [lux (#- Alias) + ["@" target] + ["." meta] + [abstract + [monad (#+ do)]] + [control + ["." io] + ["<>" parser ("#\." monad) + ["<.>" code (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text + ["%" format]] + [collection + ["." list ("#\." functor fold)]]] + [type + abstract] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code] + ["." template]]]]) + +(abstract: #export (Object brand) Any) + +(template [<name>] + [(with_expansions [<brand> (template.identifier [<name> "'"])] + (abstract: #export <brand> Any) + (type: #export <name> + (..Object <brand>)))] + + [Nil] + [Function] + ) + +(template [<name> <type>] + [(type: #export <name> + <type>)] + + [Boolean Bit] + [Integer Int] + [Float Frac] + [String Text] + ) + +(type: Nilable + [Bit Code]) + +(def: nilable + (Parser Nilable) + (let [token (' #?)] + (<| (<>.and (<>.parses? (<code>.this! token))) + (<>.after (<>.not (<code>.this! token))) + <code>.any))) + +(type: Alias + Text) + +(def: alias + (Parser Alias) + (<>.after (<code>.this! (' #as)) <code>.local_identifier)) + +(type: Field + [Bit Text (Maybe Alias) Nilable]) + +(def: static! + (Parser Any) + (<code>.this! (' #static))) + +(def: field + (Parser Field) + (<code>.form ($_ <>.and + (<>.parses? ..static!) + <code>.local_identifier + (<>.maybe ..alias) + ..nilable))) + +(def: constant + (Parser Field) + (<code>.form ($_ <>.and + (<>\wrap true) + <code>.local_identifier + (<>.maybe ..alias) + ..nilable))) + +(type: Common_Method + {#name Text + #alias (Maybe Alias) + #inputs (List Nilable) + #io? Bit + #try? Bit + #output Nilable}) + +(type: Static_Method Common_Method) +(type: Virtual_Method Common_Method) + +(type: Method + (#Static Static_Method) + (#Virtual Virtual_Method)) + +(def: common_method + (Parser Common_Method) + ($_ <>.and + <code>.local_identifier + (<>.maybe ..alias) + (<code>.tuple (<>.some ..nilable)) + (<>.parses? (<code>.this! (' #io))) + (<>.parses? (<code>.this! (' #try))) + ..nilable)) + +(def: static_method + (<>.after ..static! ..common_method)) + +(def: method + (Parser Method) + (<code>.form (<>.or ..static_method + ..common_method))) + +(type: Member + (#Field Field) + (#Method Method)) + +(def: member + (Parser Member) + ($_ <>.or + ..field + ..method + )) + +(def: input_variables + (-> (List Nilable) (List [Bit Code])) + (|>> list.enumeration + (list\map (function (_ [idx [nilable? type]]) + [nilable? (|> idx %.nat code.local_identifier)])))) + +(def: (nilable_type [nilable? type]) + (-> Nilable Code) + (if nilable? + (` (.Maybe (~ type))) + type)) + +(def: (with_nil g!temp [nilable? input]) + (-> Code [Bit Code] Code) + (if nilable? + (` (case (~ input) + (#.Some (~ g!temp)) + (~ g!temp) + + #.Nil + ("ruby object nil"))) + input)) + +(def: (without_nil g!temp [nilable? outputT] output) + (-> Code Nilable Code Code) + (if nilable? + (` (let [(~ g!temp) (~ output)] + (if ("ruby object nil?" (~ g!temp)) + #.None + (#.Some (~ g!temp))))) + (` (let [(~ g!temp) (~ output)] + (if (not ("ruby object nil?" (~ g!temp))) + (~ g!temp) + (.error! "Nil is an invalid value!")))))) + +(type: Import + (#Class Text (Maybe Alias) Text (List Member)) + (#Function Static_Method) + (#Constant Field)) + +(def: import + (Parser [(Maybe Text) Import]) + ($_ <>.and + (<>.maybe <code>.text) + ($_ <>.or + ($_ <>.and + <code>.local_identifier + (<>.maybe ..alias) + (<>.default ["" (list)] + (<code>.tuple (<>.and <code>.text + (<>.some member))))) + (<code>.form ..common_method) + ..constant + ))) + +(def: (with_io with? without) + (-> Bit Code Code) + (if with? + (` (io.io (~ without))) + without)) + +(def: (io_type io? rawT) + (-> Bit Code Code) + (if io? + (` (io.IO (~ rawT))) + rawT)) + +(def: (with_try with? without_try) + (-> Bit Code Code) + (if with? + (` (.try (~ without_try))) + without_try)) + +(def: (try_type try? rawT) + (-> Bit Code Code) + (if try? + (` (.Either .Text (~ rawT))) + rawT)) + +(def: (make_function g!method g!temp source inputsT io? try? outputT) + (-> Code Code Code (List Nilable) Bit Bit Nilable Code) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ g!method) + [(~+ (list\map product.right g!inputs))]) + (-> [(~+ (list\map nilable_type inputsT))] + (~ (|> (nilable_type outputT) + (try_type try?) + (io_type io?)))) + (:assume + (~ (<| (with_io io?) + (with_try try?) + (without_nil g!temp outputT) + (` ("ruby apply" + (:as ..Function (~ source)) + (~+ (list\map (with_nil g!temp) g!inputs))))))))))) + +(syntax: #export (import: {[?module import] ..import}) + (with_gensyms [g!temp] + (case import + (#Class [class alias format members]) + (with_gensyms [g!object] + (let [qualify (: (-> Text Code) + (function (_ member_name) + (|> format + (text.replace_all "#" (maybe.default class alias)) + (text.replace_all "." member_name) + code.local_identifier))) + g!type (code.local_identifier (maybe.default class alias)) + module_import (: (List Code) + (case ?module + (#.Some module) + (list (` ("ruby import" (~ (code.text module))))) + + #.None + (list))) + class_import (` ("ruby constant" (~ (code.text class))))] + (wrap (list& (` (type: (~ g!type) + (..Object (primitive (~ (code.text class)))))) + (list\map (function (_ member) + (case member + (#Field [static? field alias fieldT]) + (if static? + (` ((~! syntax:) ((~ (qualify (maybe.default field alias)))) + (\ (~! meta.monad) (~' wrap) + (list (` (.:as (~ (nilable_type fieldT)) + (.exec + (~+ module_import) + ("ruby constant" (~ (code.text (%.format class "::" field))))))))))) + (` (def: ((~ (qualify field)) + (~ g!object)) + (-> (~ g!type) + (~ (nilable_type fieldT))) + (:assume + (~ (without_nil g!temp fieldT (` ("ruby object get" (~ (code.text field)) + (:as (..Object .Any) (~ g!object)))))))))) + + (#Method method) + (case method + (#Static [method alias inputsT io? try? outputT]) + (..make_function (qualify (maybe.default method alias)) + g!temp + (` ("ruby object get" (~ (code.text method)) + (:as (..Object .Any) + (.exec + (~+ module_import) + ("ruby constant" (~ (code.text (%.format class "::" method)))))))) + inputsT + io? + try? + outputT) + + (#Virtual [method alias inputsT io? try? outputT]) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ (qualify (maybe.default method alias))) + [(~+ (list\map product.right g!inputs))] + (~ g!object)) + (-> [(~+ (list\map nilable_type inputsT))] + (~ g!type) + (~ (|> (nilable_type outputT) + (try_type try?) + (io_type io?)))) + (:assume + (~ (<| (with_io io?) + (with_try try?) + (without_nil g!temp outputT) + (` ("ruby object do" + (~ (code.text method)) + (~ g!object) + (~+ (list\map (with_nil g!temp) g!inputs))))))))))))) + members))))) + + (#Function [name alias inputsT io? try? outputT]) + (let [imported (` (.exec + (~+ (case ?module + (#.Some module) + (list (` ("ruby import" (~ (code.text module))))) + + #.None + (list))) + ("ruby constant" (~ (code.text name)))))] + (wrap (list (..make_function (code.local_identifier (maybe.default name alias)) + g!temp + imported + inputsT + io? + try? + outputT)))) + + (#Constant [_ name alias fieldT]) + (let [imported (` (.exec + (~+ (case ?module + (#.Some module) + (list (` ("ruby import" (~ (code.text module))))) + + #.None + (list))) + ("ruby constant" (~ (code.text name)))))] + (wrap (list (` ((~! syntax:) ((~ (code.local_identifier (maybe.default name alias)))) + (\ (~! meta.monad) (~' wrap) + (list (` (.:as (~ (nilable_type fieldT)) (~ imported)))))))))) + ))) diff --git a/stdlib/source/library/lux/ffi.scm.lux b/stdlib/source/library/lux/ffi.scm.lux new file mode 100644 index 000000000..85370fcf6 --- /dev/null +++ b/stdlib/source/library/lux/ffi.scm.lux @@ -0,0 +1,220 @@ +(.module: + [library + [lux (#- Alias) + ["@" target] + ["." meta] + [abstract + [monad (#+ do)]] + [control + ["." io] + ["<>" parser ("#\." monad) + ["<.>" code (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [type + abstract] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code] + ["." template]]]]) + +(abstract: #export (Object brand) Any) + +(template [<name>] + [(with_expansions [<brand> (template.identifier [<name> "'"])] + (abstract: #export <brand> Any) + (type: #export <name> + (..Object <brand>)))] + + [Nil] + [Function] + ) + +(template [<name> <type>] + [(type: #export <name> + <type>)] + + [Boolean Bit] + [Integer Int] + [Float Frac] + [String Text] + ) + +(type: Nilable + [Bit Code]) + +(def: nilable + (Parser Nilable) + (let [token (' #?)] + (<| (<>.and (<>.parses? (<code>.this! token))) + (<>.after (<>.not (<code>.this! token))) + <code>.any))) + +(type: Alias + Text) + +(def: alias + (Parser Alias) + (<>.after (<code>.this! (' #as)) <code>.local_identifier)) + +(type: Field + [Bit Text (Maybe Alias) Nilable]) + +(def: static! + (Parser Any) + (<code>.this! (' #static))) + +(def: field + (Parser Field) + (<code>.form ($_ <>.and + (<>.parses? ..static!) + <code>.local_identifier + (<>.maybe ..alias) + ..nilable))) + +(def: constant + (Parser Field) + (<code>.form ($_ <>.and + (<>\wrap true) + <code>.local_identifier + (<>.maybe ..alias) + ..nilable))) + +(type: Common_Method + {#name Text + #alias (Maybe Alias) + #inputs (List Nilable) + #io? Bit + #try? Bit + #output Nilable}) + +(def: common_method + (Parser Common_Method) + ($_ <>.and + <code>.local_identifier + (<>.maybe ..alias) + (<code>.tuple (<>.some ..nilable)) + (<>.parses? (<code>.this! (' #io))) + (<>.parses? (<code>.this! (' #try))) + ..nilable)) + +(def: input_variables + (-> (List Nilable) (List [Bit Code])) + (|>> list.enumeration + (list\map (function (_ [idx [nilable? type]]) + [nilable? (|> idx %.nat code.local_identifier)])))) + +(def: (nilable_type [nilable? type]) + (-> Nilable Code) + (if nilable? + (` (.Maybe (~ type))) + type)) + +(def: (with_nil g!temp [nilable? input]) + (-> Code [Bit Code] Code) + (if nilable? + (` (case (~ input) + (#.Some (~ g!temp)) + (~ g!temp) + + #.Nil + ("scheme object nil"))) + input)) + +(def: (without_nil g!temp [nilable? outputT] output) + (-> Code Nilable Code Code) + (if nilable? + (` (let [(~ g!temp) (~ output)] + (if ("scheme object nil?" (~ g!temp)) + #.None + (#.Some (~ g!temp))))) + (` (let [(~ g!temp) (~ output)] + (if (not ("scheme object nil?" (~ g!temp))) + (~ g!temp) + (.error! "Nil is an invalid value!")))))) + +(type: Import + (#Function Common_Method) + (#Constant Field)) + +(def: import + (Parser Import) + ($_ <>.or + (<code>.form ..common_method) + ..constant + )) + +(syntax: #export (try expression) + {#.doc (doc (case (try (risky_computation input)) + (#.Right success) + (do_something success) + + (#.Left error) + (recover_from_failure error)))} + (wrap (list (` ("lux try" ((~! io.io) (~ expression))))))) + +(def: (with_io with? without) + (-> Bit Code Code) + (if with? + (` (io.io (~ without))) + without)) + +(def: (io_type io? rawT) + (-> Bit Code Code) + (if io? + (` (io.IO (~ rawT))) + rawT)) + +(def: (with_try with? without_try) + (-> Bit Code Code) + (if with? + (` (..try (~ without_try))) + without_try)) + +(def: (try_type try? rawT) + (-> Bit Code Code) + (if try? + (` (.Either .Text (~ rawT))) + rawT)) + +(def: (make_function g!method g!temp source inputsT io? try? outputT) + (-> Code Code Code (List Nilable) Bit Bit Nilable Code) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ g!method) + [(~+ (list\map product.right g!inputs))]) + (-> [(~+ (list\map nilable_type inputsT))] + (~ (|> (nilable_type outputT) + (try_type try?) + (io_type io?)))) + (:assume + (~ (<| (with_io io?) + (with_try try?) + (without_nil g!temp outputT) + (` ("scheme apply" + (:as ..Function (~ source)) + (~+ (list\map (with_nil g!temp) g!inputs))))))))))) + +(syntax: #export (import: {import ..import}) + (with_gensyms [g!temp] + (case import + (#Function [name alias inputsT io? try? outputT]) + (let [imported (` ("scheme constant" (~ (code.text name))))] + (wrap (list (..make_function (code.local_identifier (maybe.default name alias)) + g!temp + imported + inputsT + io? + try? + outputT)))) + + (#Constant [_ name alias fieldT]) + (let [imported (` ("scheme constant" (~ (code.text name))))] + (wrap (list (` ((~! syntax:) ((~ (code.local_identifier (maybe.default name alias)))) + (\ (~! meta.monad) (~' wrap) + (list (` (.:as (~ (nilable_type fieldT)) (~ imported)))))))))) + ))) diff --git a/stdlib/source/library/lux/locale.lux b/stdlib/source/library/lux/locale.lux new file mode 100644 index 000000000..381938c74 --- /dev/null +++ b/stdlib/source/library/lux/locale.lux @@ -0,0 +1,45 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + ["." hash (#+ Hash)]] + [data + ["." maybe ("#\." functor)] + ["." text + ["%" format (#+ format)] + ["." encoding (#+ Encoding)]]] + [type + abstract]]] + [/ + ["." language (#+ Language)] + ["." territory (#+ Territory)]]) + +(abstract: #export Locale + Text + + (def: territory_separator "_") + (def: encoding_separator ".") + + (def: #export (locale language territory encoding) + (-> Language (Maybe Territory) (Maybe Encoding) Locale) + (:abstraction (format (language.code language) + (|> territory + (maybe\map (|>> territory.long_code (format ..territory_separator))) + (maybe.default "")) + (|> encoding + (maybe\map (|>> encoding.name (format ..encoding_separator))) + (maybe.default ""))))) + + (def: #export code + (-> Locale Text) + (|>> :representation)) + + (def: #export hash + (Hash Locale) + (\ hash.functor map ..code text.hash)) + + (def: #export equivalence + (Equivalence Locale) + (\ ..hash &equivalence)) + ) diff --git a/stdlib/source/library/lux/locale/language.lux b/stdlib/source/library/lux/locale/language.lux new file mode 100644 index 000000000..554606609 --- /dev/null +++ b/stdlib/source/library/lux/locale/language.lux @@ -0,0 +1,573 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] + [data + ["." text]] + [type + abstract] + [macro + ["." template]]]]) + +## https://en.wikipedia.org/wiki/List_of_ISO_639-2_codes +(abstract: #export Language + {#name Text + #code Text} + + (template [<name> <tag>] + [(def: #export <name> + (-> Language Text) + (|>> :representation (get@ <tag>)))] + + [name #name] + [code #code] + ) + + (template [<bundle>] + [(with_expansions [<bundle>' (template.splice <bundle>)] + (template [<code> <name> <definition> <alias>+] + [(def: #export <definition> + Language + (:abstraction {#name <name> + #code <code>})) + (`` (template [<alias>] + [(def: #export <alias> + Language + <definition>)] + + (~~ (template.splice <alias>+))))] + + <bundle>' + ))] + + [[["mis" "uncoded languages" uncoded []] + ["mul" "multiple languages" multiple []] + ["und" "undetermined" undetermined []] + ["zxx" "no linguistic content; not applicable" not_applicable []]]] + + [[["aar" "Afar" afar []] + ["abk" "Abkhazian" abkhazian []] + ["ace" "Achinese" achinese []] + ["ach" "Acoli" acoli []] + ["ada" "Adangme" adangme []] + ["ady" "Adyghe; Adygei" adyghe []] + ["afa" "Afro-Asiatic languages" afro_asiatic []] + ["afh" "Afrihili" afrihili []] + ["afr" "Afrikaans" afrikaans []] + ["ain" "Ainu" ainu []] + ["aka" "Akan" akan []] + ["akk" "Akkadian" akkadian []] + ["ale" "Aleut" aleut []] + ["alg" "Algonquian languages" algonquian []] + ["alt" "Southern Altai" southern_altai []] + ["amh" "Amharic" amharic []] + ["ang" "Old English (ca.450–1100)" old_english []] + ["anp" "Angika" angika []] + ["apa" "Apache languages" apache []] + ["ara" "Arabic" arabic []] + ["arc" "Official Aramaic (700–300 BCE); Imperial Aramaic (700–300 BCE)" official_aramaic [[imperial_aramaic]]] + ["arg" "Aragonese" aragonese []] + ["arn" "Mapudungun; Mapuche" mapudungun []] + ["arp" "Arapaho" arapaho []] + ["art" "Artificial languages" artificial []] + ["arw" "Arawak" arawak []] + ["asm" "Assamese" assamese []] + ["ast" "Asturian; Bable; Leonese; Asturleonese" asturian [[bable] [leonese] [asturleonese]]] + ["ath" "Athapascan languages" athapascan []] + ["aus" "Australian languages" australian []] + ["ava" "Avaric" avaric []] + ["ave" "Avestan" avestan []] + ["awa" "Awadhi" awadhi []] + ["aym" "Aymara" aymara []] + ["aze" "Azerbaijani" azerbaijani []]]] + + [[["bad" "Banda languages" banda []] + ["bai" "Bamileke languages" bamileke []] + ["bak" "Bashkir" bashkir []] + ["bal" "Baluchi" baluchi []] + ["bam" "Bambara" bambara []] + ["ban" "Balinese" balinese []] + ["bas" "Basa" basa []] + ["bat" "Baltic languages" baltic []] + ["bej" "Beja; Bedawiyet" beja []] + ["bel" "Belarusian" belarusian []] + ["bem" "Bemba" bemba []] + ["ben" "Bengali" bengali []] + ["ber" "Berber languages" berber []] + ["bho" "Bhojpuri" bhojpuri []] + ["bih" "Bihari languages" bihari []] + ["bik" "Bikol" bikol []] + ["bin" "Bini; Edo" bini [[edo]]] + ["bis" "Bislama" bislama []] + ["bla" "Siksika" siksika []] + ["bnt" "Bantu languages" bantu []] + ["bod" "Tibetan" tibetan []] + ["bos" "Bosnian" bosnian []] + ["bra" "Braj" braj []] + ["bre" "Breton" breton []] + ["btk" "Batak languages" batak []] + ["bua" "Buriat" buriat []] + ["bug" "Buginese" buginese []] + ["bul" "Bulgarian" bulgarian []] + ["byn" "Blin; Bilin" blin [[bilin]]]]] + + [[["cad" "Caddo" caddo []] + ["cai" "Central American Indian languages" central_american_indian []] + ["car" "Galibi Carib" galibi_carib []] + ["cat" "Catalan; Valencian" catalan [[valencian]]] + ["cau" "Caucasian languages" caucasian []] + ["ceb" "Cebuano" cebuano []] + ["cel" "Celtic languages" celtic []] + ["ces" "Czech" czech []] + ["cha" "Chamorro" chamorro []] + ["chb" "Chibcha" chibcha []] + ["che" "Chechen" chechen []] + ["chg" "Chagatai" chagatai []] + ["chk" "Chuukese" chuukese []] + ["chm" "Mari" mari []] + ["chn" "Chinook jargon" chinook []] + ["cho" "Choctaw" choctaw []] + ["chp" "Chipewyan; Dene Suline" chipewyan []] + ["chr" "Cherokee" cherokee []] + ["chu" "Church Slavic; Old Slavonic; Church Slavonic; Old Bulgarian; Old Church Slavonic" church_slavic [[old_slavonic] [church_slavonic] [old_bulgarian] [old_church_slavonic]]] + ["chv" "Chuvash" chuvash []] + ["chy" "Cheyenne" cheyenne []] + ["cmc" "Chamic languages" chamic []] + ["cnr" "Montenegrin" montenegrin []] + ["cop" "Coptic" coptic []] + ["cor" "Cornish" cornish []] + ["cos" "Corsican" corsican []] + ["cpe" "Creoles and pidgins, English based" creoles_and_pidgins/english []] + ["cpf" "Creoles and pidgins, French-based" creoles_and_pidgins/french []] + ["cpp" "Creoles and pidgins, Portuguese-based" creoles_and_pidgins/portuguese []] + ["cre" "Cree" cree []] + ["crh" "Crimean Tatar; Crimean Turkish" crimean []] + ["crp" "Creoles and pidgins" creoles_and_pidgins []] + ["csb" "Kashubian" kashubian []] + ["cus" "Cushitic languages" cushitic []] + ["cym" "Welsh" welsh []]]] + + [[["dak" "Dakota" dakota []] + ["dan" "Danish" danish []] + ["dar" "Dargwa" dargwa []] + ["day" "Land Dayak languages" land_dayak []] + ["del" "Delaware" delaware []] + ["den" "Slave (Athapascan)" slavey []] + ["deu" "German" german []] + ["dgr" "Dogrib" dogrib []] + ["din" "Dinka" dinka []] + ["div" "Divehi; Dhivehi; Maldivian" dhivehi [[maldivian]]] + ["doi" "Dogri" dogri []] + ["dra" "Dravidian languages" dravidian []] + ["dsb" "Lower Sorbian" lower_sorbian []] + ["dua" "Duala" duala []] + ["dum" "Middle Dutch (ca. 1050–1350)" middle_dutch []] + ["dyu" "Dyula" dyula []] + ["dzo" "Dzongkha" dzongkha []]]] + + [[["efi" "Efik" efik []] + ["egy" "Ancient Egyptian" egyptian []] + ["eka" "Ekajuk" ekajuk []] + ["ell" "Modern Greek (1453–)" greek []] + ["elx" "Elamite" elamite []] + ["eng" "English" english []] + ["enm" "Middle English (1100–1500)" middle_english []] + ["epo" "Esperanto" esperanto []] + ["est" "Estonian" estonian []] + ["eus" "Basque" basque []] + ["ewe" "Ewe" ewe []] + ["ewo" "Ewondo" ewondo []]]] + + [[["fan" "Fang" fang []] + ["fao" "Faroese" faroese []] + ["fas" "Persian" persian []] + ["fat" "Fanti" fanti []] + ["fij" "Fijian" fijian []] + ["fil" "Filipino; Pilipino" filipino []] + ["fin" "Finnish" finnish []] + ["fiu" "Finno-Ugrian languages" finno_ugrian []] + ["fon" "Fon" fon []] + ["fra" "French" french []] + ["frm" "Middle French (ca. 1400–1600)" middle_french []] + ["fro" "Old French (ca. 842–1400)" old_french []] + ["frr" "Northern Frisian" northern_frisian []] + ["frs" "Eastern Frisian" eastern_frisian []] + ["fry" "Western Frisian" western_frisian []] + ["ful" "Fulah" fulah []] + ["fur" "Friulian" friulian []]]] + + [[["gaa" "Ga" ga []] + ["gay" "Gayo" gayo []] + ["gba" "Gbaya" gbaya []] + ["gem" "Germanic languages" germanic []] + ["gez" "Geez" geez []] + ["gil" "Gilbertese" gilbertese []] + ["gla" "Gaelic; Scottish Gaelic" gaelic []] + ["gle" "Irish" irish []] + ["glg" "Galician" galician []] + ["glv" "Manx" manx []] + ["gmh" "Middle High German (ca. 1050–1500)" middle_high_german []] + ["goh" "Old High German (ca. 750–1050)" old_high_german []] + ["gon" "Gondi" gondi []] + ["gor" "Gorontalo" gorontalo []] + ["got" "Gothic" gothic []] + ["grb" "Grebo" grebo []] + ["grc" "Ancient Greek (to 1453)" ancient_greek []] + ["grn" "Guarani" guarani []] + ["gsw" "Swiss German; Alemannic; Alsatian" swiss_german [[alemannic] [alsatian]]] + ["guj" "Gujarati" gujarati []] + ["gwi" "Gwich'in" gwich'in []]]] + + [[["hai" "Haida" haida []] + ["hat" "Haitian; Haitian Creole" haitian []] + ["hau" "Hausa" hausa []] + ["haw" "Hawaiian" hawaiian []] + ["heb" "Hebrew" hebrew []] + ["her" "Herero" herero []] + ["hil" "Hiligaynon" hiligaynon []] + ["him" "Himachali languages; Pahari languages" himachali []] + ["hin" "Hindi" hindi []] + ["hit" "Hittite" hittite []] + ["hmn" "Hmong; Mong" hmong []] + ["hmo" "Hiri Motu" hiri_motu []] + ["hrv" "Croatian" croatian []] + ["hsb" "Upper Sorbian" upper_sorbian []] + ["hun" "Hungarian" hungarian []] + ["hup" "Hupa" hupa []] + ["hye" "Armenian" armenian []]]] + + [[["iba" "Iban" iban []] + ["ibo" "Igbo" igbo []] + ["ido" "Ido" ido []] + ["iii" "Sichuan Yi; Nuosu" sichuan_yi [[nuosu]]] + ["ijo" "Ijo languages" ijo []] + ["iku" "Inuktitut" inuktitut []] + ["ile" "Interlingue; Occidental" interlingue []] + ["ilo" "Iloko" iloko []] + ["ina" "Interlingua (International Auxiliary Language Association)" interlingua []] + ["inc" "Indic languages" indic []] + ["ind" "Indonesian" indonesian []] + ["ine" "Indo-European languages" indo_european []] + ["inh" "Ingush" ingush []] + ["ipk" "Inupiaq" inupiaq []] + ["ira" "Iranian languages" iranian []] + ["iro" "Iroquoian languages" iroquoian []] + ["isl" "Icelandic" icelandic []] + ["ita" "Italian" italian []]]] + + [[["jav" "Javanese" javanese []] + ["jbo" "Lojban" lojban []] + ["jpn" "Japanese" japanese []] + ["jpr" "Judeo-Persian" judeo_persian []] + ["jrb" "Judeo-Arabic" judeo_arabic []]]] + + [[["kaa" "Kara-Kalpak" kara_kalpak []] + ["kab" "Kabyle" kabyle []] + ["kac" "Kachin; Jingpho" kachin [[jingpho]]] + ["kal" "Kalaallisut; Greenlandic" kalaallisut [[greenlandic]]] + ["kam" "Kamba" kamba []] + ["kan" "Kannada" kannada []] + ["kar" "Karen languages" karen []] + ["kas" "Kashmiri" kashmiri []] + ["kat" "Georgian" georgian []] + ["kau" "Kanuri" kanuri []] + ["kaw" "Kawi" kawi []] + ["kaz" "Kazakh" kazakh []] + ["kbd" "Kabardian" kabardian []] + ["kha" "Khasi" khasi []] + ["khi" "Khoisan languages" khoisan []] + ["khm" "Central Khmer" central_khmer []] + ["kho" "Khotanese; Sakan" khotanese [[sakan]]] + ["kik" "Kikuyu; Gikuyu" gikuyu []] + ["kin" "Kinyarwanda" kinyarwanda []] + ["kir" "Kirghiz; Kyrgyz" kyrgyz []] + ["kmb" "Kimbundu" kimbundu []] + ["kok" "Konkani" konkani []] + ["kom" "Komi" komi []] + ["kon" "Kongo" kongo []] + ["kor" "Korean" korean []] + ["kos" "Kosraean" kosraean []] + ["kpe" "Kpelle" kpelle []] + ["krc" "Karachay-Balkar" karachay_balkar []] + ["krl" "Karelian" karelian []] + ["kro" "Kru languages" kru []] + ["kru" "Kurukh" kurukh []] + ["kua" "Kuanyama; Kwanyama" kwanyama []] + ["kum" "Kumyk" kumyk []] + ["kur" "Kurdish" kurdish []] + ["kut" "Kutenai" kutenai []]]] + + [[["lad" "Ladino" ladino []] + ["lah" "Lahnda" lahnda []] + ["lam" "Lamba" lamba []] + ["lao" "Lao" lao []] + ["lat" "Latin" latin []] + ["lav" "Latvian" latvian []] + ["lez" "Lezghian" lezghian []] + ["lim" "Limburgan; Limburger; Limburgish" limburgan []] + ["lin" "Lingala" lingala []] + ["lit" "Lithuanian" lithuanian []] + ["lol" "Mongo" mongo []] + ["loz" "Lozi" lozi []] + ["ltz" "Luxembourgish; Letzeburgesch" luxembourgish []] + ["lua" "Luba-Lulua" luba_lulua []] + ["lub" "Luba-Katanga" luba_katanga []] + ["lug" "Ganda" ganda []] + ["lui" "Luiseno" luiseno []] + ["lun" "Lunda" lunda []] + ["luo" "Luo (Kenya and Tanzania)" luo []] + ["lus" "Lushai" lushai []]]] + + [[["mad" "Madurese" madurese []] + ["mag" "Magahi" magahi []] + ["mah" "Marshallese" marshallese []] + ["mai" "Maithili" maithili []] + ["mak" "Makasar" makasar []] + ["mal" "Malayalam" malayalam []] + ["man" "Mandingo" mandingo []] + ["map" "Austronesian languages" austronesian []] + ["mar" "Marathi" marathi []] + ["mas" "Masai" masai []] + ["mdf" "Moksha" moksha []] + ["mdr" "Mandar" mandar []] + ["men" "Mende" mende []] + ["mga" "Middle Irish (900–1200)" middle_irish []] + ["mic" "Mi'kmaq; Micmac" mi'kmaq [[micmac]]] + ["min" "Minangkabau" minangkabau []] + ["mkd" "Macedonian" macedonian []] + ["mkh" "Mon-Khmer languages" mon_khmer []] + ["mlg" "Malagasy" malagasy []] + ["mlt" "Maltese" maltese []] + ["mnc" "Manchu" manchu []] + ["mni" "Manipuri" manipuri []] + ["mno" "Manobo languages" manobo []] + ["moh" "Mohawk" mohawk []] + ["mon" "Mongolian" mongolian []] + ["mos" "Mossi" mossi []] + ["mri" "Maori" maori []] + ["msa" "Malay" malay []] + ["mun" "Munda languages" munda []] + ["mus" "Creek" creek []] + ["mwl" "Mirandese" mirandese []] + ["mwr" "Marwari" marwari []] + ["mya" "Burmese" burmese []] + ["myn" "Mayan languages" mayan []] + ["myv" "Erzya" erzya []]]] + + [[["nah" "Nahuatl languages" nahuatl []] + ["nai" "North American Indian languages" north_american_indian []] + ["nap" "Neapolitan" neapolitan []] + ["nau" "Nauru" nauru []] + ["nav" "Navajo; Navaho" navajo []] + ["nbl" "South Ndebele" south_ndebele []] + ["nde" "North Ndebele" north_ndebele []] + ["ndo" "Ndonga" ndonga []] + ["nds" "Low German; Low Saxon" low_german []] + ["nep" "Nepali" nepali []] + ["new" "Nepal Bhasa; Newari" newari [[nepal_bhasa]]] + ["nia" "Nias" nias []] + ["nic" "Niger-Kordofanian languages" niger_kordofanian []] + ["niu" "Niuean" niuean []] + ["nld" "Dutch; Flemish" dutch [[flemish]]] + ["nno" "Norwegian Nynorsk" nynorsk []] + ["nob" "Norwegian Bokmål" bokmal []] + ["nog" "Nogai" nogai []] + ["non" "Old Norse" old_norse []] + ["nor" "Norwegian" norwegian []] + ["nqo" "N'Ko" n'ko []] + ["nso" "Pedi; Sepedi; Northern Sotho" northern_sotho [[pedi] [sepedi]]] + ["nub" "Nubian languages" nubian []] + ["nwc" "Classical Newari; Old Newari; Classical Nepal Bhasa" old_newari [[classical_newari] [classical_nepal_bhasa]]] + ["nya" "Chichewa; Chewa; Nyanja" nyanja [[chichewa] [chewa]]] + ["nym" "Nyamwezi" nyamwezi []] + ["nyn" "Nyankole" nyankole []] + ["nyo" "Nyoro" nyoro []] + ["nzi" "Nzima" nzima []]]] + + [[["oci" "Occitan (post 1500); Provençal" occitan [[provencal]]] + ["oji" "Ojibwa" ojibwa []] + ["ori" "Oriya" oriya []] + ["orm" "Oromo" oromo []] + ["osa" "Osage" osage []] + ["oss" "Ossetian; Ossetic" ossetic []] + ["ota" "Ottoman Turkish (1500–1928)" ottoman_turkish []] + ["oto" "Otomian languages" otomian []]]] + + [[["paa" "Papuan languages" papuan []] + ["pag" "Pangasinan" pangasinan []] + ["pal" "Pahlavi" pahlavi []] + ["pam" "Pampanga; Kapampangan" pampanga [[kapampangan]]] + ["pan" "Panjabi; Punjabi" punjabi []] + ["pap" "Papiamento" papiamento []] + ["pau" "Palauan" palauan []] + ["peo" "Old Persian (ca. 600–400 B.C.)" old_persian []] + ["phi" "Philippine languages" philippine []] + ["phn" "Phoenician" phoenician []] + ["pli" "Pali" pali []] + ["pol" "Polish" polish []] + ["pon" "Pohnpeian" pohnpeian []] + ["por" "Portuguese" portuguese []] + ["pra" "Prakrit languages" prakrit []] + ["pro" "Old Provençal (to 1500); Old Occitan (to 1500)" old_provencal []] + ["pus" "Pushto; Pashto" pashto []]]] + + [[["que" "Quechua" quechua []]]] + + [[["raj" "Rajasthani" rajasthani []] + ["rap" "Rapanui" rapanui []] + ["rar" "Rarotongan; Cook Islands Maori" rarotongan [[cook_islands_maori]]] + ["roa" "Romance languages" romance []] + ["roh" "Romansh" romansh []] + ["rom" "Romany" romany []] + ["ron" "Romanian; Moldavian; Moldovan" romanian [[moldavian] [moldovan]]] + ["run" "Rundi" rundi []] + ["rup" "Aromanian; Arumanian; Macedo-Romanian" aromanian [[arumanian] [macedo_romanian]]] + ["rus" "Russian" russian []]]] + + [[["sad" "Sandawe" sandawe []] + ["sag" "Sango" sango []] + ["sah" "Yakut" yakut []] + ["sai" "South American Indian (Other)" south_american_indian []] + ["sal" "Salishan languages" salishan []] + ["sam" "Samaritan Aramaic" samaritan_aramaic []] + ["san" "Sanskrit" sanskrit []] + ["sas" "Sasak" sasak []] + ["sat" "Santali" santali []] + ["scn" "Sicilian" sicilian []] + ["sco" "Scots" scots []] + ["sel" "Selkup" selkup []] + ["sem" "Semitic languages" semitic []] + ["sga" "Old Irish (to 900)" old_irish []] + ["sgn" "Sign Languages" sign []] + ["shn" "Shan" shan []] + ["sid" "Sidamo" sidamo []] + ["sin" "Sinhala; Sinhalese" sinhalese []] + ["sio" "Siouan languages" siouan []] + ["sit" "Sino-Tibetan languages" sino_tibetan []] + ["sla" "Slavic languages" slavic []] + ["slk" "Slovak" slovak []] + ["slv" "Slovenian" slovenian []] + ["sma" "Southern Sami" southern_sami []] + ["sme" "Northern Sami" northern_sami []] + ["smi" "Sami languages" sami []] + ["smj" "Lule Sami" lule []] + ["smn" "Inari Sami" inari []] + ["smo" "Samoan" samoan []] + ["sms" "Skolt Sami" skolt_sami []] + ["sna" "Shona" shona []] + ["snd" "Sindhi" sindhi []] + ["snk" "Soninke" soninke []] + ["sog" "Sogdian" sogdian []] + ["som" "Somali" somali []] + ["son" "Songhai languages" songhai []] + ["sot" "Southern Sotho" southern_sotho []] + ["spa" "Spanish; Castilian" spanish [[castilian]]] + ["sqi" "Albanian" albanian []] + ["srd" "Sardinian" sardinian []] + ["srn" "Sranan Tongo" sranan_tongo []] + ["srp" "Serbian" serbian []] + ["srr" "Serer" serer []] + ["ssa" "Nilo-Saharan languages" nilo_saharan []] + ["ssw" "Swati" swati []] + ["suk" "Sukuma" sukuma []] + ["sun" "Sundanese" sundanese []] + ["sus" "Susu" susu []] + ["sux" "Sumerian" sumerian []] + ["swa" "Swahili" swahili []] + ["swe" "Swedish" swedish []] + ["syc" "Classical Syriac" classical_syriac []] + ["syr" "Syriac" syriac []]]] + + [[["tah" "Tahitian" tahitian []] + ["tai" "Tai languages" tai []] + ["tam" "Tamil" tamil []] + ["tat" "Tatar" tatar []] + ["tel" "Telugu" telugu []] + ["tem" "Timne" timne []] + ["ter" "Tereno" tereno []] + ["tet" "Tetum" tetum []] + ["tgk" "Tajik" tajik []] + ["tgl" "Tagalog" tagalog []] + ["tha" "Thai" thai []] + ["tig" "Tigre" tigre []] + ["tir" "Tigrinya" tigrinya []] + ["tiv" "Tiv" tiv []] + ["tkl" "Tokelau" tokelau []] + ["tlh" "Klingon; tlhIngan-Hol" klingon []] + ["tli" "Tlingit" tlingit []] + ["tmh" "Tamashek" tamashek []] + ["tog" "Tonga (Nyasa)" tonga []] + ["ton" "Tonga (Tonga Islands)" tongan []] + ["tpi" "Tok Pisin" tok_pisin []] + ["tsi" "Tsimshian" tsimshian []] + ["tsn" "Tswana" tswana []] + ["tso" "Tsonga" tsonga []] + ["tuk" "Turkmen" turkmen []] + ["tum" "Tumbuka" tumbuka []] + ["tup" "Tupi languages" tupi []] + ["tur" "Turkish" turkish []] + ["tut" "Altaic languages" altaic []] + ["tvl" "Tuvalu" tuvalu []] + ["twi" "Twi" twi []] + ["tyv" "Tuvinian" tuvinian []]]] + + [[["udm" "Udmurt" udmurt []] + ["uga" "Ugaritic" ugaritic []] + ["uig" "Uighur; Uyghur" uyghur []] + ["ukr" "Ukrainian" ukrainian []] + ["umb" "Umbundu" umbundu []] + ["urd" "Urdu" urdu []] + ["uzb" "Uzbek" uzbek []]]] + + [[["vai" "Vai" vai []] + ["ven" "Venda" venda []] + ["vie" "Vietnamese" vietnamese []] + ["vol" "Volapük" volapük []] + ["vot" "Votic" votic []]]] + + [[["wak" "Wakashan languages" wakashan []] + ["wal" "Wolaitta; Wolaytta" walamo []] + ["war" "Waray" waray []] + ["was" "Washo" washo []] + ["wen" "Sorbian languages" sorbian []] + ["wln" "Walloon" walloon []] + ["wol" "Wolof" wolof []]]] + + [[["xal" "Kalmyk; Oirat" kalmyk [[oirat]]] + ["xho" "Xhosa" xhosa []]]] + + [[["yao" "Yao" yao []] + ["yap" "Yapese" yapese []] + ["yid" "Yiddish" yiddish []] + ["yor" "Yoruba" yoruba []] + ["ypk" "Yupik languages" yupik []]]] + + [[["zap" "Zapotec" zapotec []] + ["zbl" "Blissymbols; Blissymbolics; Bliss" blissymbols []] + ["zen" "Zenaga" zenaga []] + ["zgh" "Standard Moroccan Tamazight" standard_moroccan_tamazight []] + ["zha" "Zhuang; Chuang" zhuang []] + ["zho" "Chinese" chinese []] + ["znd" "Zande languages" zande []] + ["zul" "Zulu" zulu []] + ["zun" "Zuni" zuni []] + ["zza" "Zaza; Dimili; Dimli; Kirdki; Kirmanjki; Zazaki" zaza [[dimili] [dimli] [kirdki] [kirmanjki] [zazaki]]]]]) + + (implementation: #export equivalence + (Equivalence Language) + + (def: (= reference sample) + (is? reference sample))) + + (implementation: #export hash + (Hash Language) + + (def: &equivalence + ..equivalence) + + (def: hash + (|>> ..code + (\ text.hash hash)))) + ) diff --git a/stdlib/source/library/lux/locale/territory.lux b/stdlib/source/library/lux/locale/territory.lux new file mode 100644 index 000000000..be60b6734 --- /dev/null +++ b/stdlib/source/library/lux/locale/territory.lux @@ -0,0 +1,312 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] + [data + ["." text]] + [type + abstract] + [macro + ["." template]]]]) + +## https://en.wikipedia.org/wiki/ISO_3166-1 +(abstract: #export Territory + {#name Text + #short Text + #long Text + #code Nat} + + (template [<name> <field> <type>] + [(def: #export <name> + (-> Territory <type>) + (|>> :representation + (get@ <field>)))] + + [name #name Text] + [short_code #short Text] + [long_code #long Text] + [numeric_code #code Nat] + ) + + (template [<short> <long> <number> <name> <main> <neighbor>+] + [(def: #export <main> + Territory + (:abstraction {#name <name> + #short <short> + #long <long> + #code <number>})) + + (`` (template [<neighbor>] + [(def: #export <neighbor> Territory <main>)] + + (~~ (template.splice <neighbor>+))))] + + ["AF" "AFG" 004 "Afghanistan" afghanistan []] + ["AX" "ALA" 248 "Åland Islands" aland_islands []] + ["AL" "ALB" 008 "Albania" albania []] + ["DZ" "DZA" 012 "Algeria" algeria []] + ["AS" "ASM" 016 "American Samoa" american_samoa []] + ["AD" "AND" 020 "Andorra" andorra []] + ["AO" "AGO" 024 "Angola" angola []] + ["AI" "AIA" 660 "Anguilla" anguilla []] + ["AQ" "ATA" 010 "Antarctica" antarctica []] + ["AG" "ATG" 028 "Antigua and Barbuda" antigua [[barbuda]]] + ["AR" "ARG" 032 "Argentina" argentina []] + ["AM" "ARM" 051 "Armenia" armenia []] + ["AW" "ABW" 533 "Aruba" aruba []] + ["AU" "AUS" 036 "Australia" australia []] + ["AT" "AUT" 040 "Austria" austria []] + ["AZ" "AZE" 031 "Azerbaijan" azerbaijan []] + ["BS" "BHS" 044 "The Bahamas" the_bahamas []] + ["BH" "BHR" 048 "Bahrain" bahrain []] + ["BD" "BGD" 050 "Bangladesh" bangladesh []] + ["BB" "BRB" 052 "Barbados" barbados []] + ["BY" "BLR" 112 "Belarus" belarus []] + ["BE" "BEL" 056 "Belgium" belgium []] + ["BZ" "BLZ" 084 "Belize" belize []] + ["BJ" "BEN" 204 "Benin" benin []] + ["BM" "BMU" 060 "Bermuda" bermuda []] + ["BT" "BTN" 064 "Bhutan" bhutan []] + ["BO" "BOL" 068 "Bolivia" bolivia []] + ["BQ" "BES" 535 "Bonaire, Sint Eustatius and Saba" bonaire [[sint_eustatius] [saba]]] + ["BA" "BIH" 070 "Bosnia and Herzegovina" bosnia [[herzegovina]]] + ["BW" "BWA" 072 "Botswana" botswana []] + ["BV" "BVT" 074 "Bouvet Island" bouvet_island []] + ["BR" "BRA" 076 "Brazil" brazil []] + ["IO" "IOT" 086 "British Indian Ocean Territory" british_indian_ocean_territory []] + ["BN" "BRN" 096 "Brunei Darussalam" brunei_darussalam []] + ["BG" "BGR" 100 "Bulgaria" bulgaria []] + ["BF" "BFA" 854 "Burkina Faso" burkina_faso []] + ["BI" "BDI" 108 "Burundi" burundi []] + ["CV" "CPV" 132 "Cape Verde" cape_verde []] + ["KH" "KHM" 116 "Cambodia" cambodia []] + ["CM" "CMR" 120 "Cameroon" cameroon []] + ["CA" "CAN" 124 "Canada" canada []] + ["KY" "CYM" 136 "Cayman Islands" cayman_islands []] + ["CF" "CAF" 140 "Central African Republic" central_african_republic []] + ["TD" "TCD" 148 "Chad" chad []] + ["CL" "CHL" 152 "Chile" chile []] + ["CN" "CHN" 156 "China" china []] + ["CX" "CXR" 162 "Christmas Island" christmas_island []] + ["CC" "CCK" 166 "Cocos (Keeling) Islands" cocos_islands []] + ["CO" "COL" 170 "Colombia" colombia []] + ["KM" "COM" 174 "Comoros" comoros []] + ["CG" "COG" 178 "Congo" congo []] + ["CD" "COD" 180 "Democratic Republic of the Congo" democratic_republic_of_the_congo []] + ["CK" "COK" 184 "Cook Islands" cook_islands []] + ["CR" "CRI" 188 "Costa Rica" costa_rica []] + ["CI" "CIV" 384 "Ivory Coast" ivory_coast []] + ["HR" "HRV" 191 "Croatia" croatia []] + ["CU" "CUB" 192 "Cuba" cuba []] + ["CW" "CUW" 531 "Curacao" curacao []] + ["CY" "CYP" 196 "Cyprus" cyprus []] + ["CZ" "CZE" 203 "Czech Republic" czech_republic []] + ["DK" "DNK" 208 "Denmark" denmark []] + ["DJ" "DJI" 262 "Djibouti" djibouti []] + ["DM" "DMA" 212 "Dominica" dominica []] + ["DO" "DOM" 214 "Dominican Republic" dominican_republic []] + ["EC" "ECU" 218 "Ecuador" ecuador []] + ["EG" "EGY" 818 "Egypt" egypt []] + ["SV" "SLV" 222 "El Salvador" el_salvador []] + ["GQ" "GNQ" 226 "Equatorial Guinea" equatorial_guinea []] + ["ER" "ERI" 232 "Eritrea" eritrea []] + ["EE" "EST" 233 "Estonia" estonia []] + ["SZ" "SWZ" 748 "Eswatini" eswatini []] + ["ET" "ETH" 231 "Ethiopia" ethiopia []] + ["FK" "FLK" 238 "Falkland Islands" falkland_islands []] + ["FO" "FRO" 234 "Faroe Islands" faroe_islands []] + ["FJ" "FJI" 242 "Fiji" fiji []] + ["FI" "FIN" 246 "Finland" finland []] + ["FR" "FRA" 250 "France" france []] + ["GF" "GUF" 254 "French Guiana" french_guiana []] + ["PF" "PYF" 258 "French Polynesia" french_polynesia []] + ["TF" "ATF" 260 "French Southern Territories" french_southern_territories []] + ["GA" "GAB" 266 "Gabon" gabon []] + ["GM" "GMB" 270 "The Gambia" the_gambia []] + ["GE" "GEO" 268 "Georgia" georgia []] + ["DE" "DEU" 276 "Germany" germany []] + ["GH" "GHA" 288 "Ghana" ghana []] + ["GI" "GIB" 292 "Gibraltar" gibraltar []] + ["GR" "GRC" 300 "Greece" greece []] + ["GL" "GRL" 304 "Greenland" greenland []] + ["GD" "GRD" 308 "Grenada" grenada []] + ["GP" "GLP" 312 "Guadeloupe" guadeloupe []] + ["GU" "GUM" 316 "Guam" guam []] + ["GT" "GTM" 320 "Guatemala" guatemala []] + ["GG" "GGY" 831 "Guernsey" guernsey []] + ["GN" "GIN" 324 "Guinea" guinea []] + ["GW" "GNB" 624 "Guinea-Bissau" guinea_bissau []] + ["GY" "GUY" 328 "Guyana" guyana []] + ["HT" "HTI" 332 "Haiti" haiti []] + ["HM" "HMD" 334 "Heard Island and McDonald Islands" heard_island [[mcdonald_islands]]] + ["VA" "VAT" 336 "Vatican City" vatican_city []] + ["HN" "HND" 340 "Honduras" honduras []] + ["HK" "HKG" 344 "Hong Kong" hong_kong []] + ["HU" "HUN" 348 "Hungary" hungary []] + ["IS" "ISL" 352 "Iceland" iceland []] + ["IN" "IND" 356 "India" india []] + ["ID" "IDN" 360 "Indonesia" indonesia []] + ["IR" "IRN" 364 "Iran" iran []] + ["IQ" "IRQ" 368 "Iraq" iraq []] + ["IE" "IRL" 372 "Ireland" ireland []] + ["IM" "IMN" 833 "Isle of Man" isle_of_man []] + ["IL" "ISR" 376 "Israel" israel []] + ["IT" "ITA" 380 "Italy" italy []] + ["JM" "JAM" 388 "Jamaica" jamaica []] + ["JP" "JPN" 392 "Japan" japan []] + ["JE" "JEY" 832 "Jersey" jersey []] + ["JO" "JOR" 400 "Jordan" jordan []] + ["KZ" "KAZ" 398 "Kazakhstan" kazakhstan []] + ["KE" "KEN" 404 "Kenya" kenya []] + ["KI" "KIR" 296 "Kiribati" kiribati []] + ["KP" "PRK" 408 "North Korea" north_korea []] + ["KR" "KOR" 410 "South Korea" south_korea []] + ["KW" "KWT" 414 "Kuwait" kuwait []] + ["KG" "KGZ" 417 "Kyrgyzstan" kyrgyzstan []] + ["LA" "LAO" 418 "Laos" laos []] + ["LV" "LVA" 428 "Latvia" latvia []] + ["LB" "LBN" 422 "Lebanon" lebanon []] + ["LS" "LSO" 426 "Lesotho" lesotho []] + ["LR" "LBR" 430 "Liberia" liberia []] + ["LY" "LBY" 434 "Libya" libya []] + ["LI" "LIE" 438 "Liechtenstein" liechtenstein []] + ["LT" "LTU" 440 "Lithuania" lithuania []] + ["LU" "LUX" 442 "Luxembourg" luxembourg []] + ["MO" "MAC" 446 "Macau" macau []] + ["MK" "MKD" 807 "Macedonia" macedonia []] + ["MG" "MDG" 450 "Madagascar" madagascar []] + ["MW" "MWI" 454 "Malawi" malawi []] + ["MY" "MYS" 458 "Malaysia" malaysia []] + ["MV" "MDV" 462 "Maldives" maldives []] + ["ML" "MLI" 466 "Mali" mali []] + ["MT" "MLT" 470 "Malta" malta []] + ["MH" "MHL" 584 "Marshall Islands" marshall_islands []] + ["MQ" "MTQ" 474 "Martinique" martinique []] + ["MR" "MRT" 478 "Mauritania" mauritania []] + ["MU" "MUS" 480 "Mauritius" mauritius []] + ["YT" "MYT" 175 "Mayotte" mayotte []] + ["MX" "MEX" 484 "Mexico" mexico []] + ["FM" "FSM" 583 "Micronesia" micronesia []] + ["MD" "MDA" 498 "Moldova" moldova []] + ["MC" "MCO" 492 "Monaco" monaco []] + ["MN" "MNG" 496 "Mongolia" mongolia []] + ["ME" "MNE" 499 "Montenegro" montenegro []] + ["MS" "MSR" 500 "Montserrat" montserrat []] + ["MA" "MAR" 504 "Morocco" morocco []] + ["MZ" "MOZ" 508 "Mozambique" mozambique []] + ["MM" "MMR" 104 "Myanmar" myanmar []] + ["NA" "NAM" 516 "Namibia" namibia []] + ["NR" "NRU" 520 "Nauru" nauru []] + ["NP" "NPL" 524 "Nepal" nepal []] + ["NL" "NLD" 528 "Netherlands" netherlands []] + ["NC" "NCL" 540 "New Caledonia" new_caledonia []] + ["NZ" "NZL" 554 "New Zealand" new_zealand []] + ["NI" "NIC" 558 "Nicaragua" nicaragua []] + ["NE" "NER" 562 "Niger" niger []] + ["NG" "NGA" 566 "Nigeria" nigeria []] + ["NU" "NIU" 570 "Niue" niue []] + ["NF" "NFK" 574 "Norfolk Island" norfolk_island []] + ["MP" "MNP" 580 "Northern Mariana Islands" northern_mariana_islands []] + ["NO" "NOR" 578 "Norway" norway []] + ["OM" "OMN" 512 "Oman" oman []] + ["PK" "PAK" 586 "Pakistan" pakistan []] + ["PW" "PLW" 585 "Palau" palau []] + ["PS" "PSE" 275 "Palestine" palestine []] + ["PA" "PAN" 591 "Panama" panama []] + ["PG" "PNG" 598 "Papua New Guinea" papua_new_guinea []] + ["PY" "PRY" 600 "Paraguay" paraguay []] + ["PE" "PER" 604 "Peru" peru []] + ["PH" "PHL" 608 "Philippines" philippines []] + ["PN" "PCN" 612 "Pitcairn Islands" pitcairn_islands []] + ["PL" "POL" 616 "Poland" poland []] + ["PT" "PRT" 620 "Portugal" portugal []] + ["PR" "PRI" 630 "Puerto Rico" puerto_rico []] + ["QA" "QAT" 634 "Qatar" qatar []] + ["RE" "REU" 638 "Reunion" reunion []] + ["RO" "ROU" 642 "Romania" romania []] + ["RU" "RUS" 643 "Russia" russia []] + ["RW" "RWA" 646 "Rwanda" rwanda []] + ["BL" "BLM" 652 "Saint Barthélemy" saint_barthelemy []] + ["SH" "SHN" 654 "Saint Helena, Ascension and Tristan da Cunha" saint_helena [[ascension] [tristan_da_cunha]]] + ["KN" "KNA" 659 "Saint Kitts and Nevis" saint_kitts [[nevis]]] + ["LC" "LCA" 662 "Saint Lucia" saint_lucia []] + ["MF" "MAF" 663 "Saint Martin" saint_martin []] + ["PM" "SPM" 666 "Saint Pierre and Miquelon" saint_pierre [[miquelon]]] + ["VC" "VCT" 670 "Saint Vincent and the Grenadines" saint_vincent [[the_grenadines]]] + ["WS" "WSM" 882 "Samoa" samoa []] + ["SM" "SMR" 674 "San Marino" san_marino []] + ["ST" "STP" 678 "Sao Tome and Principe" sao_tome [[principe]]] + ["SA" "SAU" 682 "Saudi Arabia" saudi_arabia []] + ["SN" "SEN" 686 "Senegal" senegal []] + ["RS" "SRB" 688 "Serbia" serbia []] + ["SC" "SYC" 690 "Seychelles" seychelles []] + ["SL" "SLE" 694 "Sierra Leone" sierra_leone []] + ["SG" "SGP" 702 "Singapore" singapore []] + ["SX" "SXM" 534 "Sint Maarten" sint_maarten []] + ["SK" "SVK" 703 "Slovakia" slovakia []] + ["SI" "SVN" 705 "Slovenia" slovenia []] + ["SB" "SLB" 090 "Solomon Islands" solomon_islands []] + ["SO" "SOM" 706 "Somalia" somalia []] + ["ZA" "ZAF" 710 "South Africa" south_africa []] + ["GS" "SGS" 239 "South Georgia and the South Sandwich Islands" south_georgia [[south_sandwich_islands]]] + ["SS" "SSD" 728 "South Sudan" south_sudan []] + ["ES" "ESP" 724 "Spain" spain []] + ["LK" "LKA" 144 "Sri Lanka" sri_lanka []] + ["SD" "SDN" 729 "Sudan" sudan []] + ["SR" "SUR" 740 "Suriname" suriname []] + ["SJ" "SJM" 744 "Svalbard and Jan Mayen" svalbard [[jan_mayen]]] + ["SE" "SWE" 752 "Sweden" sweden []] + ["CH" "CHE" 756 "Switzerland" switzerland []] + ["SY" "SYR" 760 "Syria" syria []] + ["TW" "TWN" 158 "Taiwan" taiwan []] + ["TJ" "TJK" 762 "Tajikistan" tajikistan []] + ["TZ" "TZA" 834 "Tanzania" tanzania []] + ["TH" "THA" 764 "Thailand" thailand []] + ["TL" "TLS" 626 "East Timor" east_timor []] + ["TG" "TGO" 768 "Togo" togo []] + ["TK" "TKL" 772 "Tokelau" tokelau []] + ["TO" "TON" 776 "Tonga" tonga []] + ["TT" "TTO" 780 "Trinidad and Tobago" trinidad [[tobago]]] + ["TN" "TUN" 788 "Tunisia" tunisia []] + ["TR" "TUR" 792 "Turkey" turkey []] + ["TM" "TKM" 795 "Turkmenistan" turkmenistan []] + ["TC" "TCA" 796 "Turks and Caicos Islands" turks [[caicos_islands]]] + ["TV" "TUV" 798 "Tuvalu" tuvalu []] + ["UG" "UGA" 800 "Uganda" uganda []] + ["UA" "UKR" 804 "Ukraine" ukraine []] + ["AE" "ARE" 784 "United Arab Emirates" united_arab_emirates []] + ["GB" "GBR" 826 "United Kingdom of Great Britain and Northern Ireland" united_kingdom [[northern_ireland]]] + ["US" "USA" 840 "United States of America" united_states_of_america []] + ["UM" "UMI" 581 "United States Minor Outlying Islands" united_states_minor_outlying_islands []] + ["UY" "URY" 858 "Uruguay" uruguay []] + ["UZ" "UZB" 860 "Uzbekistan" uzbekistan []] + ["VU" "VUT" 548 "Vanuatu" vanuatu []] + ["VE" "VEN" 862 "Venezuela" venezuela []] + ["VN" "VNM" 704 "Vietnam" vietnam []] + ["VG" "VGB" 092 "British Virgin Islands" british_virgin_islands []] + ["VI" "VIR" 850 "United States Virgin Islands" united_states_virgin_islands []] + ["WF" "WLF" 876 "Wallis and Futuna" wallis [[futuna]]] + ["EH" "ESH" 732 "Western Sahara" western_sahara []] + ["YE" "YEM" 887 "Yemen" yemen []] + ["ZM" "ZMB" 894 "Zambia" zambia []] + ["ZW" "ZWE" 716 "Zimbabwe" zimbabwe []] + ) + + (implementation: #export equivalence + (Equivalence Territory) + + (def: (= reference sample) + (is? reference sample))) + + (implementation: #export hash + (Hash Territory) + + (def: &equivalence ..equivalence) + + (def: hash + (|>> :representation + (get@ #long) + (\ text.hash hash)))) + ) diff --git a/stdlib/source/library/lux/macro.lux b/stdlib/source/library/lux/macro.lux new file mode 100644 index 000000000..c446dfa70 --- /dev/null +++ b/stdlib/source/library/lux/macro.lux @@ -0,0 +1,210 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [data + ["." text ("#\." monoid)] + ["." name ("#\." codec)] + [collection + ["." list ("#\." monoid monad)]]] + [macro + ["." code]] + [math + [number + ["." nat] + ["." int]]]]] + ["." // #_ + ["#" meta + ["." location]]]) + +(def: #export (expand_once syntax) + {#.doc (doc "Given code that requires applying a macro, does it once and returns the result." + "Otherwise, returns the code as-is.")} + (-> Code (Meta (List Code))) + (case syntax + [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] + (do //.monad + [?macro (//.find_macro name)] + (case ?macro + (#.Some macro) + ((:as Macro' macro) args) + + #.None + (\ //.monad wrap (list syntax)))) + + _ + (\ //.monad wrap (list syntax)))) + +(def: #export (expand syntax) + {#.doc (doc "Given code that requires applying a macro, expands repeatedly until no more direct macro-calls are left." + "Otherwise, returns the code as-is.")} + (-> Code (Meta (List Code))) + (case syntax + [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] + (do //.monad + [?macro (//.find_macro name)] + (case ?macro + (#.Some macro) + (do //.monad + [expansion ((:as Macro' macro) args) + expansion' (monad.map //.monad expand expansion)] + (wrap (list\join expansion'))) + + #.None + (\ //.monad wrap (list syntax)))) + + _ + (\ //.monad wrap (list syntax)))) + +(def: #export (expand_all syntax) + {#.doc "Expands all macro-calls everywhere recursively, until only primitive/base code remains."} + (-> Code (Meta (List Code))) + (case syntax + [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] + (do //.monad + [?macro (//.find_macro name)] + (case ?macro + (#.Some macro) + (do //.monad + [expansion ((:as Macro' macro) args) + expansion' (monad.map //.monad expand_all expansion)] + (wrap (list\join expansion'))) + + #.None + (do //.monad + [parts' (monad.map //.monad expand_all (list& (code.identifier name) args))] + (wrap (list (code.form (list\join parts'))))))) + + [_ (#.Form (#.Cons [harg targs]))] + (do //.monad + [harg+ (expand_all harg) + targs+ (monad.map //.monad expand_all targs)] + (wrap (list (code.form (list\compose harg+ (list\join (: (List (List Code)) targs+))))))) + + [_ (#.Tuple members)] + (do //.monad + [members' (monad.map //.monad expand_all members)] + (wrap (list (code.tuple (list\join members'))))) + + [_ (#.Record members)] + (|> members + (monad.map //.monad + (function (_ [left right]) + (do //.monad + [left (expand_all left) + right (expand_all right)] + (case [left right] + [(#.Cons left #.Nil) (#.Cons right #.Nil)] + (wrap [left right]) + + _ + (//.fail "Record members must expand into singletons."))))) + (\ //.monad map (|>> code.record list))) + + _ + (\ //.monad wrap (list syntax)))) + +(def: #export (gensym prefix) + {#.doc (doc "Generates a unique name as an Code node (ready to be used in code templates)." + "A prefix can be given (or just be empty text) to better identify the code for debugging purposes.")} + (-> Text (Meta Code)) + (do //.monad + [id //.count] + (wrap (|> id + (\ nat.decimal encode) + ($_ text\compose "__gensym__" prefix) + [""] code.identifier)))) + +(def: (get_local_identifier ast) + (-> Code (Meta Text)) + (case ast + [_ (#.Identifier [_ name])] + (\ //.monad wrap name) + + _ + (//.fail (text\compose "Code is not a local identifier: " (code.format ast))))) + +(def: #export wrong_syntax_error + (-> Name Text) + (|>> name\encode + (text\compose "Wrong syntax for "))) + +(macro: #export (with_gensyms tokens) + {#.doc (doc "Creates new identifiers and offers them to the body expression." + (syntax: #export (synchronized lock body) + (with_gensyms [g!lock g!body g!_] + (wrap (list (` (let [(~ g!lock) (~ lock) + (~ g!_) ("jvm monitorenter" (~ g!lock)) + (~ g!body) (~ body) + (~ g!_) ("jvm monitorexit" (~ g!lock))] + (~ g!body))))) + )))} + (case tokens + (^ (list [_ (#.Tuple identifiers)] body)) + (do {! //.monad} + [identifier_names (monad.map ! ..get_local_identifier identifiers) + #let [identifier_defs (list\join (list\map (: (-> Text (List Code)) + (function (_ name) (list (code.identifier ["" name]) (` (gensym (~ (code.text name))))))) + identifier_names))]] + (wrap (list (` ((~! do) (~! //.monad) + [(~+ identifier_defs)] + (~ body)))))) + + _ + (//.fail (..wrong_syntax_error (name_of ..with_gensyms))))) + +(def: #export (expand_1 token) + {#.doc "Works just like expand, except that it ensures that the output is a single Code token."} + (-> Code (Meta Code)) + (do //.monad + [token+ (..expand token)] + (case token+ + (^ (list token')) + (wrap token') + + _ + (//.fail "Macro expanded to more than 1 element.")))) + +(template [<macro> <func>] + [(macro: #export (<macro> tokens) + {#.doc (doc "Performs a macro-expansion and logs the resulting code." + "You can either use the resulting code, or omit them." + "By omitting them, this macro produces nothing (just like the lux.comment macro)." + (<macro> #omit + (def: (foo bar baz) + (-> Int Int Int) + (int.+ bar baz))))} + (let [[module _] (name_of .._) + [_ short] (name_of <macro>) + macro_name [module short]] + (case (: (Maybe [Bit Code]) + (case tokens + (^ (list [_ (#.Tag ["" "omit"])] + token)) + (#.Some [#1 token]) + + (^ (list token)) + (#.Some [#0 token]) + + _ + #.None)) + (#.Some [omit? token]) + (do //.monad + [location //.location + output (<func> token) + #let [_ ("lux io log" ($_ text\compose (name\encode macro_name) " " (location.format location))) + _ (list\map (|>> code.format "lux io log") + output) + _ ("lux io log" "")]] + (wrap (if omit? + (list) + output))) + + #.None + (//.fail (..wrong_syntax_error macro_name)))))] + + [log_expand_once! expand_once] + [log_expand! expand] + [log_expand_all! expand_all] + ) diff --git a/stdlib/source/library/lux/macro/code.lux b/stdlib/source/library/lux/macro/code.lux new file mode 100644 index 000000000..ec99f68a4 --- /dev/null +++ b/stdlib/source/library/lux/macro/code.lux @@ -0,0 +1,161 @@ +(.module: + [library + [lux (#- nat int rev) + [abstract + [equivalence (#+ Equivalence)]] + [data + ["." product] + ["." bit] + ["." name] + ["." text ("#\." monoid equivalence)] + [collection + ["." list ("#\." functor fold)]]] + [math + [number + ["." nat] + ["." int] + ["." rev] + ["." frac]]] + [meta + ["." location]]]]) + +## (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))]))) + +## (type: Code +## (Ann Location (Code' (Ann Location)))) + +(template [<name> <type> <tag>] + [(def: #export (<name> x) + (-> <type> Code) + [location.dummy (<tag> x)])] + + [bit Bit #.Bit] + [nat Nat #.Nat] + [int Int #.Int] + [rev Rev #.Rev] + [frac Frac #.Frac] + [text Text #.Text] + [identifier Name #.Identifier] + [tag Name #.Tag] + [form (List Code) #.Form] + [tuple (List Code) #.Tuple] + [record (List [Code Code]) #.Record] + ) + +(template [<name> <tag> <doc>] + [(def: #export (<name> name) + {#.doc <doc>} + (-> Text Code) + [location.dummy (<tag> ["" name])])] + + [local_identifier #.Identifier "Produces a local identifier (an identifier with no module prefix)."] + [local_tag #.Tag "Produces a local tag (a tag with no module prefix)."]) + +(implementation: #export equivalence + (Equivalence Code) + + (def: (= x y) + (case [x y] + (^template [<tag> <eq>] + [[[_ (<tag> x')] [_ (<tag> y')]] + (\ <eq> = x' y')]) + ([#.Bit bit.equivalence] + [#.Nat nat.equivalence] + [#.Int int.equivalence] + [#.Rev rev.equivalence] + [#.Frac frac.equivalence] + [#.Text text.equivalence] + [#.Identifier name.equivalence] + [#.Tag name.equivalence]) + + (^template [<tag>] + [[[_ (<tag> xs')] [_ (<tag> ys')]] + (\ (list.equivalence =) = xs' ys')]) + ([#.Form] + [#.Tuple]) + + [[_ (#.Record xs')] [_ (#.Record ys')]] + (\ (list.equivalence (product.equivalence = =)) + = xs' ys') + + _ + false))) + +(def: #export (format ast) + (-> Code Text) + (case ast + (^template [<tag> <struct>] + [[_ (<tag> value)] + (\ <struct> encode value)]) + ([#.Bit bit.codec] + [#.Nat nat.decimal] + [#.Int int.decimal] + [#.Rev rev.decimal] + [#.Frac frac.decimal] + [#.Identifier name.codec]) + + [_ (#.Text value)] + (text.format value) + + [_ (#.Tag name)] + (text\compose "#" (\ name.codec encode name)) + + (^template [<tag> <open> <close>] + [[_ (<tag> members)] + ($_ text\compose + <open> + (list\fold (function (_ next prev) + (let [next (format next)] + (if (text\= "" prev) + next + ($_ text\compose prev " " next)))) + "" + members) + <close>)]) + ([#.Form "(" ")"] + [#.Tuple "[" "]"]) + + [_ (#.Record pairs)] + ($_ text\compose + "{" + (list\fold (function (_ [left right] prev) + (let [next ($_ text\compose (format left) " " (format right))] + (if (text\= "" prev) + next + ($_ text\compose prev " " next)))) + "" + pairs) + "}") + )) + +(def: #export (replace original substitute ast) + {#.doc "Replaces all code that looks like the 'original' with the 'substitute'."} + (-> Code Code Code Code) + (if (\ ..equivalence = original ast) + substitute + (case ast + (^template [<tag>] + [[location (<tag> parts)] + [location (<tag> (list\map (replace original substitute) parts))]]) + ([#.Form] + [#.Tuple]) + + [location (#.Record parts)] + [location (#.Record (list\map (function (_ [left right]) + [(replace original substitute left) + (replace original substitute right)]) + parts))] + + _ + ast))) diff --git a/stdlib/source/library/lux/macro/local.lux b/stdlib/source/library/lux/macro/local.lux new file mode 100644 index 000000000..4eb9c35c6 --- /dev/null +++ b/stdlib/source/library/lux/macro/local.lux @@ -0,0 +1,106 @@ +(.module: + [library + [lux #* + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." text] + [collection + ["." list ("#\." functor)] + [dictionary + ["." plist (#+ PList)]]]]]] + ["." // + ["#." code]]) + +(exception: #export (unknown_module {module Text}) + (exception.report + ["Module" (text.format module)])) + +(template [<name>] + [(exception: #export (<name> {module Text} {definition Text}) + (exception.report + ["Module" (text.format module)] + ["Definition" (text.format definition)]))] + + [cannot_shadow_definition] + [unknown_definition] + ) + +(def: (with_module name body) + (All [a] (-> Text (-> Module (Try [Module a])) (Meta a))) + (function (_ compiler) + (case (|> compiler (get@ #.modules) (plist.get name)) + (#.Some module) + (case (body module) + (#try.Success [module' output]) + (#try.Success [(update@ #.modules (plist.put name module') compiler) + output]) + + (#try.Failure error) + (#try.Failure error)) + + #.None + (exception.throw ..unknown_module [name])))) + +(def: (push_one [name macro]) + (-> [Name Macro] (Meta Any)) + (do meta.monad + [[module_name definition_name] (meta.normalize name) + #let [definition (: Global (#.Definition [false .Macro (' {}) macro])) + add_macro! (: (-> (PList Global) (PList Global)) + (plist.put definition_name definition))]] + (..with_module module_name + (function (_ module) + (case (|> module (get@ #.definitions) (plist.get definition_name)) + #.None + (#try.Success [(update@ #.definitions add_macro! module) + []]) + + (#.Some _) + (exception.throw ..cannot_shadow_definition [module_name definition_name])))))) + +(def: (pop_one name) + (-> Name (Meta Any)) + (do meta.monad + [[module_name definition_name] (meta.normalize name) + #let [remove_macro! (: (-> (PList Global) (PList Global)) + (plist.remove definition_name))]] + (..with_module module_name + (function (_ module) + (case (|> module (get@ #.definitions) (plist.get definition_name)) + (#.Some _) + (#try.Success [(update@ #.definitions remove_macro! module) + []]) + + #.None + (exception.throw ..unknown_definition [module_name definition_name])))))) + +(def: (pop_all macros self) + (-> (List Name) Name Macro) + ("lux macro" + (function (_ _) + (do {! meta.monad} + [_ (monad.map ! ..pop_one macros) + _ (..pop_one self) + compiler meta.get_compiler] + (wrap (case (get@ #.expected compiler) + (#.Some _) + (list (' [])) + + #.None + (list))))))) + +(def: #export (push macros) + (-> (List [Name Macro]) (Meta Code)) + (do meta.monad + [_ (monad.map meta.monad ..push_one macros) + seed meta.count + g!pop (//.gensym "pop") + _ (let [g!pop (: Name ["" (//code.format g!pop)])] + (..push_one [g!pop (..pop_all (list\map product.left macros) g!pop)]))] + (wrap (` ((~ g!pop)))))) diff --git a/stdlib/source/library/lux/macro/poly.lux b/stdlib/source/library/lux/macro/poly.lux new file mode 100644 index 000000000..5ce420e7a --- /dev/null +++ b/stdlib/source/library/lux/macro/poly.lux @@ -0,0 +1,128 @@ +(.module: + [library + [lux #* + ["." meta] + ["." type] + [abstract + ["." monad (#+ do)]] + [control + ["p" parser + ["<.>" type (#+ Env)] + ["s" code]]] + [data + ["." product] + ["." maybe] + ["." text] + [collection + ["." list ("#\." fold functor)] + ["." dictionary]]] + [macro (#+ with_gensyms) + ["." code] + [syntax (#+ syntax:) + ["|.|" export]]] + [math + [number + ["n" nat]]]]]) + +(syntax: #export (poly: {export |export|.parser} + {name s.local_identifier} + body) + (with_gensyms [g!_ g!type g!output] + (let [g!name (code.identifier ["" name])] + (wrap (.list (` ((~! syntax:) (~+ (|export|.format export)) ((~ g!name) {(~ g!type) (~! s.identifier)}) + ((~! do) (~! meta.monad) + [(~ g!type) ((~! meta.find_type_def) (~ g!type))] + (case (: (.Either .Text .Code) + ((~! <type>.run) ((~! p.rec) + (function ((~ g!_) (~ g!name)) + (~ body))) + (~ g!type))) + (#.Left (~ g!output)) + ((~! meta.fail) (~ g!output)) + + (#.Right (~ g!output)) + ((~' wrap) (.list (~ g!output)))))))))))) + +(def: (common_poly_name? poly_func) + (-> Text Bit) + (text.contains? "?" poly_func)) + +(def: (derivation_name poly args) + (-> Text (List Text) (Maybe Text)) + (if (common_poly_name? poly) + (#.Some (list\fold (text.replace_once "?") poly args)) + #.None)) + +(syntax: #export (derived: {export |export|.parser} + {?name (p.maybe s.local_identifier)} + {[poly_func poly_args] (s.form (p.and s.identifier (p.many s.identifier)))} + {?custom_impl (p.maybe s.any)}) + (do {! meta.monad} + [poly_args (monad.map ! meta.normalize poly_args) + name (case ?name + (#.Some name) + (wrap name) + + (^multi #.None + [(derivation_name (product.right poly_func) (list\map product.right poly_args)) + (#.Some derived_name)]) + (wrap derived_name) + + _ + (p.fail "derived: was given no explicit name, and cannot generate one from given information.")) + #let [impl (case ?custom_impl + (#.Some custom_impl) + custom_impl + + #.None + (` ((~ (code.identifier poly_func)) (~+ (list\map code.identifier poly_args)))))]] + (wrap (.list (` (def: (~+ (|export|.format export)) + (~ (code.identifier ["" name])) + {#.implementation? #1} + (~ impl))))))) + +(def: #export (to_code env type) + (-> Env Type Code) + (`` (case type + (#.Primitive name params) + (` (#.Primitive (~ (code.text name)) + (list (~+ (list\map (to_code env) params))))) + + (^template [<tag>] + [(<tag> idx) + (` (<tag> (~ (code.nat idx))))]) + ([#.Var] [#.Ex]) + + (#.Parameter idx) + (let [idx (<type>.adjusted_idx env idx)] + (if (n.= 0 idx) + (|> (dictionary.get idx env) maybe.assume product.left (to_code env)) + (` (.$ (~ (code.nat (dec idx))))))) + + (#.Apply (#.Named [(~~ (static .prelude_module)) "Nothing"] _) (#.Parameter idx)) + (let [idx (<type>.adjusted_idx env idx)] + (if (n.= 0 idx) + (|> (dictionary.get idx env) maybe.assume product.left (to_code env)) + (undefined))) + + (^template [<tag>] + [(<tag> left right) + (` (<tag> (~ (to_code env left)) + (~ (to_code env right))))]) + ([#.Function] [#.Apply]) + + (^template [<macro> <tag> <flattener>] + [(<tag> left right) + (` (<macro> (~+ (list\map (to_code env) (<flattener> type)))))]) + ([| #.Sum type.flatten_variant] + [& #.Product type.flatten_tuple]) + + (#.Named name sub_type) + (code.identifier name) + + (^template [<tag>] + [(<tag> scope body) + (` (<tag> (list (~+ (list\map (to_code env) scope))) + (~ (to_code env body))))]) + ([#.UnivQ] [#.ExQ]) + ))) diff --git a/stdlib/source/library/lux/macro/syntax.lux b/stdlib/source/library/lux/macro/syntax.lux new file mode 100644 index 000000000..c2ddeefe5 --- /dev/null +++ b/stdlib/source/library/lux/macro/syntax.lux @@ -0,0 +1,129 @@ +(.module: + [library + [lux #* + ["." macro (#+ with_gensyms)] + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["<>" parser + ["</>" code (#+ Parser)]]] + [data + ["." maybe] + ["." text ("#\." monoid)] + [collection + ["." list ("#\." functor)]]] + [math + [number + ["." nat] + ["." int] + ["." rev] + ["." frac]]]]] + [// + ["." code]]) + +(def: (self_documenting binding parser) + (All [a] (-> Code (Parser a) (Parser a))) + (function (_ tokens) + (case (parser tokens) + (#try.Success [tokens output]) + (#try.Success [tokens output]) + + (#try.Failure error) + (#try.Failure ($_ text\compose + "Failed to parse: " (code.format binding) text.new_line + error))))) + +(def: (join_pairs pairs) + (All [a] (-> (List [a a]) (List a))) + (case pairs + #.Nil #.Nil + (#.Cons [[x y] pairs']) (list& x y (join_pairs pairs')))) + +(macro: #export (syntax: tokens) + {#.doc (doc "A more advanced way to define macros than 'macro:'." + "The inputs to the macro can be parsed in complex ways through the use of syntax parsers." + "The macro body is also (implicitly) run in the Meta monad, to save some typing." + "Also, the compiler state can be accessed through the *compiler* binding." + (syntax: #export (object {#let [imports (class_imports *compiler*)]} + {#let [class_vars (list)]} + {super (opt (super_class_decl^ imports class_vars))} + {interfaces (tuple (some (super_class_decl^ imports class_vars)))} + {constructor_args (constructor_args^ imports class_vars)} + {methods (some (overriden_method_def^ imports))}) + (let [def_code ($_ text\compose "anon-class:" + (spaced (list (super_class_decl$ (maybe.default object_super_class super)) + (with_brackets (spaced (list\map super_class_decl$ interfaces))) + (with_brackets (spaced (list\map constructor_arg$ constructor_args))) + (with_brackets (spaced (list\map (method_def$ id) methods))))))] + (wrap (list (` ((~ (code.text def_code)))))))))} + (let [[exported? tokens] (: [Bit (List Code)] + (case tokens + (^ (list& [_ (#.Tag ["" "export"])] tokens')) + [#1 tokens'] + + _ + [#0 tokens])) + ?parts (: (Maybe [Text (List Code) Code Code]) + (case tokens + (^ (list [_ (#.Form (list& [_ (#.Identifier ["" name])] args))] + body)) + (#.Some name args (` {}) body) + + (^ (list [_ (#.Form (list& [_ (#.Identifier ["" name])] args))] + meta_data + body)) + (#.Some name args meta_data body) + + _ + #.None))] + (case ?parts + (#.Some [name args meta body]) + (with_gensyms [g!tokens g!body g!error] + (do {! meta.monad} + [vars+parsers (monad.map ! + (: (-> Code (Meta [Code Code])) + (function (_ arg) + (case arg + (^ [_ (#.Record (list [var parser]))]) + (case var + [_ (#.Tag ["" "let"])] + (wrap [var parser]) + + _ + (wrap [var + (` ((~! ..self_documenting) (' (~ var)) + (~ parser)))])) + + [_ (#.Identifier var_name)] + (wrap [arg + (` ((~! ..self_documenting) (' (~ arg)) + (~! </>.any)))]) + + _ + (meta.fail "Syntax pattern expects records or identifiers.")))) + args) + this_module meta.current_module_name + #let [g!state (code.identifier ["" "*compiler*"]) + error_msg (code.text (macro.wrong_syntax_error [this_module name])) + export_ast (: (List Code) + (if exported? + (list (' #export)) + (list)))]] + (wrap (list (` (macro: (~+ export_ast) ((~ (code.identifier ["" name])) (~ g!tokens) (~ g!state)) + (~ meta) + ({(#.Right (~ g!body)) + ((~ g!body) (~ g!state)) + + (#.Left (~ g!error)) + (#.Left ((~! text.join_with) (~! text.new_line) (list (~ error_msg) (~ g!error))))} + ((~! </>.run) + (: ((~! </>.Parser) (Meta (List Code))) + ((~! do) (~! <>.monad) + [(~+ (..join_pairs vars+parsers))] + ((~' wrap) (~ body)))) + (~ g!tokens))))))))) + + _ + (meta.fail (macro.wrong_syntax_error (name_of ..syntax:)))))) diff --git a/stdlib/source/library/lux/macro/syntax/annotations.lux b/stdlib/source/library/lux/macro/syntax/annotations.lux new file mode 100644 index 000000000..28f5a233e --- /dev/null +++ b/stdlib/source/library/lux/macro/syntax/annotations.lux @@ -0,0 +1,42 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [control + ["." function] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." product] + ["." name] + [collection + ["." list ("#\." functor)]]] + [macro + ["." code]]]]) + +(type: #export Annotations + (List [Name Code])) + +(def: #export equivalence + (Equivalence Annotations) + (list.equivalence + (product.equivalence name.equivalence + code.equivalence))) + +(def: #export empty + Annotations + (list)) + +(def: #export format + (-> Annotations Code) + (let [entry (product.apply code.tag function.identity)] + (|>> (list\map entry) + code.record))) + +(def: #export parser + (Parser Annotations) + (<code>.record + (<>.some + (<>.and <code>.tag + <code>.any)))) diff --git a/stdlib/source/library/lux/macro/syntax/check.lux b/stdlib/source/library/lux/macro/syntax/check.lux new file mode 100644 index 000000000..bd4214eab --- /dev/null +++ b/stdlib/source/library/lux/macro/syntax/check.lux @@ -0,0 +1,42 @@ +(.module: + [library + [lux #* + ["." meta] + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ do)]] + [control + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." product]] + [macro + ["." code]]]]) + +(def: extension + "lux check") + +(type: #export Check + {#type Code + #value Code}) + +(def: #export equivalence + (Equivalence Check) + ($_ product.equivalence + code.equivalence + code.equivalence + )) + +(def: #export (format (^slots [#type #value])) + (-> Check Code) + (` ((~ (code.text ..extension)) + (~ type) + (~ value)))) + +(def: #export parser + (Parser Check) + (<| <code>.form + (<>.after (<code>.text! ..extension)) + (<>.and <code>.any + <code>.any))) diff --git a/stdlib/source/library/lux/macro/syntax/declaration.lux b/stdlib/source/library/lux/macro/syntax/declaration.lux new file mode 100644 index 000000000..d1c7d94c6 --- /dev/null +++ b/stdlib/source/library/lux/macro/syntax/declaration.lux @@ -0,0 +1,47 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [control + ["<>" parser ("#\." monad) + ["<.>" code (#+ Parser)]]] + [data + ["." product] + ["." text] + [collection + ["." list ("#\." functor)]]] + [macro + ["." code]]]]) + +(type: #export Declaration + {#name Text + #arguments (List Text)}) + +(def: #export equivalence + (Equivalence Declaration) + ($_ product.equivalence + text.equivalence + (list.equivalence text.equivalence) + )) + +(def: #export parser + {#.doc (doc "A parser for declaration syntax." + "Such as:" + quux + (foo bar baz))} + (Parser Declaration) + (<>.either (<>.and <code>.local_identifier + (<>\wrap (list))) + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))) + +(def: #export (format value) + (-> Declaration Code) + (let [g!name (code.local_identifier (get@ #name value))] + (case (get@ #arguments value) + #.Nil + g!name + + arguments + (` ((~ g!name) (~+ (list\map code.local_identifier arguments))))))) diff --git a/stdlib/source/library/lux/macro/syntax/definition.lux b/stdlib/source/library/lux/macro/syntax/definition.lux new file mode 100644 index 000000000..1e309a306 --- /dev/null +++ b/stdlib/source/library/lux/macro/syntax/definition.lux @@ -0,0 +1,141 @@ +(.module: + [library + [lux (#- Definition) + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ do)]] + [control + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." sum] + ["." product] + ["." bit] + ["." name] + ["." text + ["%" format]] + [collection + ["." list]]] + ["." macro + ["." code]] + ["." meta + ["." location]]]] + ["." // + ["#." annotations (#+ Annotations)] + ["#." check (#+ Check)]]) + +(type: #export Definition + {#name Text + #value (Either Check + Code) + #anns Annotations + #export? Bit}) + +(def: #export equivalence + (Equivalence Definition) + ($_ product.equivalence + text.equivalence + ($_ sum.equivalence + //check.equivalence + code.equivalence + ) + //annotations.equivalence + bit.equivalence + )) + +(def: extension + "lux def") + +(def: (format_tag [module short]) + (-> Name Code) + (` [(~ (code.text module)) + (~ (code.text short))])) + +(def: (format_annotations value) + (-> Annotations Code) + (case value + #.Nil + (` #.Nil) + + (#.Cons [name value] tail) + (` (#.Cons [(~ (..format_tag name)) + (~ value)] + (~ (format_annotations tail)))))) + +(def: dummy + Code + (` {#.module (~ (code.text (get@ #.module location.dummy))) + #.line (~ (code.nat (get@ #.line location.dummy))) + #.column (~ (code.nat (get@ #.column location.dummy)))})) + +(def: #export (format (^slots [#name #value #anns #export?])) + (-> Definition Code) + (` ((~ (code.text ..extension)) + (~ (code.local_identifier name)) + (~ (case value + (#.Left check) + (//check.format check) + + (#.Right value) + value)) + [(~ ..dummy) (#.Record (~ (..format_annotations anns)))] + (~ (code.bit export?))))) + +(def: tag_parser + (Parser Name) + (<code>.tuple (<>.and <code>.text <code>.text))) + +(def: annotations_parser + (Parser Annotations) + (<>.rec + (function (_ recur) + ($_ <>.or + (<code>.tag! (name_of #.Nil)) + (<code>.form (do <>.monad + [_ (<code>.tag! (name_of #.Cons)) + [head tail] (<>.and (<code>.tuple (<>.and tag_parser <code>.any)) + recur)] + (wrap [head tail]))) + )))) + +(def: #export (parser compiler) + {#.doc "A reader that first macro-expands and then analyses the input Code, to ensure it's a definition."} + (-> Lux (Parser Definition)) + (do {! <>.monad} + [raw <code>.any + me_raw (|> raw + macro.expand_all + (meta.run compiler) + <>.lift)] + (<| (<code>.local me_raw) + <code>.form + (<>.after (<code>.text! ..extension)) + ($_ <>.and + <code>.local_identifier + (<>.or //check.parser + <code>.any) + (<| <code>.tuple + (<>.after <code>.any) + <code>.form + (<>.after (<code>.this! (` #.Record))) + ..annotations_parser) + <code>.bit + )))) + +(exception: #export (lacks_type! {definition Definition}) + (exception.report + ["Definition" (%.code (..format definition))])) + +(def: #export (typed compiler) + {#.doc "Only works for typed definitions."} + (-> Lux (Parser Definition)) + (do <>.monad + [definition (..parser compiler) + _ (case (get@ #value definition) + (#.Left _) + (wrap []) + + (#.Right _) + (<>.lift (exception.throw ..lacks_type! [definition])))] + (wrap definition))) diff --git a/stdlib/source/library/lux/macro/syntax/export.lux b/stdlib/source/library/lux/macro/syntax/export.lux new file mode 100644 index 000000000..d76aa6fcc --- /dev/null +++ b/stdlib/source/library/lux/macro/syntax/export.lux @@ -0,0 +1,21 @@ +(.module: + [library + [lux #* + [control + ["<>" parser ("#\." monad) + ["<.>" code (#+ Parser)]]]]]) + +(def: token + (' #export)) + +(def: #export (format exported?) + (-> Bit (List Code)) + (if exported? + (list ..token) + (list))) + +(def: #export parser + (Parser Bit) + (<>.either (<>.after (<code>.this! ..token) + (<>\wrap true)) + (<>\wrap false))) diff --git a/stdlib/source/library/lux/macro/syntax/input.lux b/stdlib/source/library/lux/macro/syntax/input.lux new file mode 100644 index 000000000..9307322d9 --- /dev/null +++ b/stdlib/source/library/lux/macro/syntax/input.lux @@ -0,0 +1,38 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [control + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." product]] + [macro + ["." code]]]]) + +(type: #export Input + {#binding Code + #type Code}) + +(def: #export equivalence + (Equivalence Input) + ($_ product.equivalence + code.equivalence + code.equivalence + )) + +(def: #export (format value) + (-> Input Code) + (code.record + (list [(get@ #binding value) + (get@ #type value)]))) + +(def: #export parser + {#.doc "Parser for the common typed-argument syntax used by many macros."} + (Parser Input) + (<code>.record + ($_ <>.and + <code>.any + <code>.any + ))) diff --git a/stdlib/source/library/lux/macro/syntax/type/variable.lux b/stdlib/source/library/lux/macro/syntax/type/variable.lux new file mode 100644 index 000000000..e73020c42 --- /dev/null +++ b/stdlib/source/library/lux/macro/syntax/type/variable.lux @@ -0,0 +1,28 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [control + [parser + ["<.>" code (#+ Parser)]]] + [data + ["." text]] + [macro + ["." code]]]]) + +(type: #export Variable + Text) + +(def: #export equivalence + (Equivalence Variable) + text.equivalence) + +(def: #export format + (-> Variable Code) + code.local_identifier) + +(def: #export parser + {#.doc "Parser for the common type variable/parameter used by many macros."} + (Parser Variable) + <code>.local_identifier) diff --git a/stdlib/source/library/lux/macro/template.lux b/stdlib/source/library/lux/macro/template.lux new file mode 100644 index 000000000..c489703fc --- /dev/null +++ b/stdlib/source/library/lux/macro/template.lux @@ -0,0 +1,185 @@ +(.module: + [library + [lux (#- let) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser ("#\." functor) + ["<.>" code (#+ Parser)]]] + [data + ["." bit ("#\." codec)] + ["." text] + [collection + ["." list ("#\." monad)] + ["." dictionary (#+ Dictionary)]]] + [math + [number + ["." nat ("#\." decimal)] + ["." int ("#\." decimal)] + ["." rev ("#\." decimal)] + ["." frac ("#\." decimal)]]]]] + ["." // + [syntax (#+ syntax:)] + ["." code] + ["." local]]) + +(syntax: #export (splice {parts (<code>.tuple (<>.some <code>.any))}) + (wrap parts)) + +(syntax: #export (count {parts (<code>.tuple (<>.some <code>.any))}) + (wrap (list (code.nat (list.size parts))))) + +(syntax: #export (with_locals {locals (<code>.tuple (<>.some <code>.local_identifier))} + body) + (do {! meta.monad} + [g!locals (|> locals + (list\map //.gensym) + (monad.seq !))] + (wrap (list (` (.with_expansions [(~+ (|> (list.zip/2 locals g!locals) + (list\map (function (_ [name identifier]) + (list (code.local_identifier name) (as_is identifier)))) + list\join))] + (~ body))))))) + +(def: (name_side module_side? parser) + (-> Bit (Parser Name) (Parser Text)) + (do <>.monad + [[module short] parser] + (wrap (if module_side? + (case module + "" short + _ module) + short)))) + +(def: (snippet module_side?) + (-> Bit (Parser Text)) + (.let [full_identifier (..name_side module_side? <code>.identifier) + full_tag (..name_side module_side? <code>.tag)] + ($_ <>.either + <code>.text + (if module_side? + full_identifier + (<>.either <code>.local_identifier + full_identifier)) + (if module_side? + full_tag + (<>.either <code>.local_tag + full_tag)) + (<>\map bit\encode <code>.bit) + (<>\map nat\encode <code>.nat) + (<>\map int\encode <code>.int) + (<>\map rev\encode <code>.rev) + (<>\map frac\encode <code>.frac) + ))) + +(def: (part module_side?) + (-> Bit (Parser (List Text))) + (<code>.tuple (<>.many (..snippet module_side?)))) + +(syntax: #export (text {simple (..part false)}) + (wrap (list (|> simple (text.join_with "") code.text)))) + +(template [<name> <simple> <complex>] + [(syntax: #export (<name> {name (<>.or (<>.and (..part true) (..part false)) + (..part false))}) + (case name + (#.Left [simple complex]) + (wrap (list (<complex> [(text.join_with "" simple) + (text.join_with "" complex)]))) + + (#.Right simple) + (wrap (list (|> simple (text.join_with "") <simple>)))))] + + [identifier code.local_identifier code.identifier] + [tag code.local_tag code.tag] + ) + +(type: Environment + (Dictionary Text Code)) + +(def: (apply env template) + (-> Environment Code Code) + (case template + [_ (#.Identifier "" name)] + (case (dictionary.get name env) + (#.Some substitute) + substitute + + #.None + template) + + (^template [<tag>] + [[meta (<tag> elems)] + [meta (<tag> (list\map (apply env) elems))]]) + ([#.Tuple] + [#.Form]) + + [meta (#.Record members)] + [meta (#.Record (list\map (: (-> [Code Code] [Code Code]) + (function (_ [key value]) + [(apply env key) + (apply env value)])) + members))] + + _ + template)) + +(type: Local + {#name Text + #parameters (List Text) + #template (List Code)}) + +(exception: #export (irregular_arguments {expected Nat} {actual Nat}) + (exception.report + ["Expected" (\ nat.decimal encode expected)] + ["Actual" (\ nat.decimal encode actual)])) + +(def: (macro (^slots [#parameters #template])) + (-> Local Macro) + ("lux macro" + (function (_ inputs compiler) + (.let [parameters_count (list.size parameters) + inputs_count (list.size inputs)] + (if (nat.= parameters_count inputs_count) + (.let [environment (: Environment + (|> (list.zip/2 parameters inputs) + (dictionary.from_list text.hash)))] + (#.Right [compiler (list\map (..apply environment) template)])) + (exception.throw ..irregular_arguments [parameters_count inputs_count])))))) + +(def: local + (Parser Local) + (do <>.monad + [[name parameters] (<code>.form (<>.and <code>.local_identifier + (<>.many <code>.local_identifier))) + template (<code>.tuple (<>.some <code>.any))] + (wrap {#name name + #parameters parameters + #template template}))) + +(syntax: #export (let {locals (<code>.tuple (<>.some ..local))} + body) + (do meta.monad + [here_name meta.current_module_name + expression? (: (Meta Bit) + (function (_ lux) + (#try.Success [lux (case (get@ #.expected lux) + #.None + false + + (#.Some _) + true)]))) + g!pop (local.push (list\map (function (_ local) + [[here_name (get@ #name local)] + (..macro local)]) + locals))] + (if expression? + (//.with_gensyms [g!body] + (wrap (list (` (.let [(~ g!body) (~ body)] + (exec (~ g!pop) + (~ g!body))))))) + (wrap (list body + g!pop))))) diff --git a/stdlib/source/library/lux/math.lux b/stdlib/source/library/lux/math.lux new file mode 100644 index 000000000..0070bcfa3 --- /dev/null +++ b/stdlib/source/library/lux/math.lux @@ -0,0 +1,394 @@ +(.module: {#.doc "Common mathematical constants and functions."} + [library + [lux #* + ["@" target] + [math + [number + ["n" nat] + ["i" int]]]]]) + +(template [<name> <value> <doc>] + [(def: #export <name> + {#.doc <doc>} + <value>)] + + [e +2.7182818284590452354 "The base of the natural logarithm."] + [pi +3.14159265358979323846 "The ratio of a circle's circumference to its diameter."] + [tau +6.28318530717958647692 "The ratio of a circle's circumference to its radius."] + ) + +(for {@.old + (as_is (template [<name> <method>] + [(def: #export (<name> input) + (-> Frac Frac) + (<method> input))] + + [cos "jvm invokestatic:java.lang.Math:cos:double"] + [sin "jvm invokestatic:java.lang.Math:sin:double"] + [tan "jvm invokestatic:java.lang.Math:tan:double"] + + [acos "jvm invokestatic:java.lang.Math:acos:double"] + [asin "jvm invokestatic:java.lang.Math:asin:double"] + [atan "jvm invokestatic:java.lang.Math:atan:double"] + + [exp "jvm invokestatic:java.lang.Math:exp:double"] + [log "jvm invokestatic:java.lang.Math:log:double"] + + [ceil "jvm invokestatic:java.lang.Math:ceil:double"] + [floor "jvm invokestatic:java.lang.Math:floor:double"] + ) + (def: #export (pow param subject) + (-> Frac Frac Frac) + ("jvm invokestatic:java.lang.Math:pow:double,double" subject param))) + + @.jvm + (as_is (template: (!double value) + (|> value + (:as (primitive "java.lang.Double")) + "jvm object cast")) + + (template: (!frac value) + (|> value + "jvm object cast" + (: (primitive "java.lang.Double")) + (:as Frac))) + + (template [<name> <method>] + [(def: #export <name> + (-> Frac Frac) + (|>> !double + ["D"] + ("jvm member invoke static" [] "java.lang.Math" <method> []) + !frac))] + + [cos "cos"] + [sin "sin"] + [tan "tan"] + + [acos "acos"] + [asin "asin"] + [atan "atan"] + + [exp "exp"] + [log "log"] + + [ceil "ceil"] + [floor "floor"] + + [root/2 "sqrt"] + [root/3 "cbrt"] + ) + + (def: #export (pow param subject) + (-> Frac Frac Frac) + (|> ("jvm member invoke static" [] "java.lang.Math" "pow" [] + ["D" (!double subject)] ["D" (!double param)]) + !frac))) + + @.js + (as_is (template [<name> <method>] + [(def: #export <name> + (-> Frac Frac) + (|>> ("js apply" ("js constant" <method>)) + (:as Frac)))] + + [cos "Math.cos"] + [sin "Math.sin"] + [tan "Math.tan"] + + [acos "Math.acos"] + [asin "Math.asin"] + [atan "Math.atan"] + + [exp "Math.exp"] + [log "Math.log"] + + [ceil "Math.ceil"] + [floor "Math.floor"] + + [root/2 "Math.sqrt"] + [root/3 "Math.cbrt"] + ) + + (def: #export (pow param subject) + (-> Frac Frac Frac) + (:as Frac ("js apply" ("js constant" "Math.pow") subject param)))) + + @.python + (as_is (template [<name> <method>] + [(def: #export <name> + (-> Frac Frac) + (|>> ("python object do" <method> ("python import" "math")) + (:as Frac)))] + + [cos "cos"] + [sin "sin"] + [tan "tan"] + + [acos "acos"] + [asin "asin"] + [atan "atan"] + + [exp "exp"] + [log "log"] + + [ceil "ceil"] + [floor "floor"] + + [root/2 "sqrt"] + ) + + (def: #export (pow param subject) + (-> Frac Frac Frac) + (:as Frac ("python object do" "pow" ("python import" "math") subject param))) + + (def: #export root/3 + (-> Frac Frac) + (..pow ("lux f64 /" +3.0 +1.0)))) + + @.lua + (as_is (template [<name> <method>] + [(def: #export <name> + (-> Frac Frac) + (|>> ("lua apply" ("lua constant" <method>)) + (:as Frac)))] + + [cos "math.cos"] + [sin "math.sin"] + [tan "math.tan"] + + [acos "math.acos"] + [asin "math.asin"] + [atan "math.atan"] + + [exp "math.exp"] + [log "math.log"] + + [ceil "math.ceil"] + [floor "math.floor"] + + [root/2 "math.sqrt"] + ) + + (def: #export (pow param subject) + (-> Frac Frac Frac) + ("lua power" param subject)) + + (def: #export root/3 + (-> Frac Frac) + (..pow ("lux f64 /" +3.0 +1.0)))) + + @.ruby + (as_is (template [<name> <method>] + [(def: #export <name> + (-> Frac Frac) + (|>> ("ruby apply" ("ruby constant" <method>)) + (:as Frac)))] + + [cos "Math.cos"] + [sin "Math.sin"] + [tan "Math.tan"] + + [acos "Math.acos"] + [asin "Math.asin"] + [atan "Math.atan"] + + [exp "Math.exp"] + [log "Math.log"] + + [root/2 "Math.sqrt"] + [root/3 "Math.cbrt"] + ) + + (template [<name> <method>] + [(def: #export <name> + (-> Frac Frac) + (|>> ("ruby object do" <method>) + (:as Int) + ("lux i64 f64")))] + + [ceil "ceil"] + [floor "floor"] + ) + + (def: #export (pow param subject) + (-> Frac Frac Frac) + (:as Frac ("ruby object do" "**" subject param)))) + + @.php + (as_is (template [<name> <method>] + [(def: #export <name> + (-> Frac Frac) + (|>> ("php apply" ("php constant" <method>)) + (:as Frac)))] + + [cos "cos"] + [sin "sin"] + [tan "tan"] + + [acos "acos"] + [asin "asin"] + [atan "atan"] + + [exp "exp"] + [log "log"] + + [ceil "ceil"] + [floor "floor"] + + [root/2 "sqrt"] + ) + + (def: #export (pow param subject) + (-> Frac Frac Frac) + (:as Frac ("php apply" ("php constant" "pow") subject param))) + + (def: #export root/3 + (-> Frac Frac) + (..pow ("lux f64 /" +3.0 +1.0)))) + + @.scheme + (as_is (template [<name> <method>] + [(def: #export <name> + (-> Frac Frac) + (|>> ("scheme apply" ("scheme constant" <method>)) + (:as Frac)))] + + [cos "cos"] + [sin "sin"] + [tan "tan"] + + [acos "acos"] + [asin "asin"] + [atan "atan"] + + [exp "exp"] + [log "log"] + + [ceil "ceiling"] + [floor "floor"] + + [root/2 "sqrt"] + ) + + (def: #export (pow param subject) + (-> Frac Frac Frac) + (:as Frac ("scheme apply" ("scheme constant" "expt") subject param))) + + (def: #export root/3 + (-> Frac Frac) + (..pow ("lux f64 /" +3.0 +1.0)))) + }) + +(def: #export (round input) + (-> Frac Frac) + (let [floored (floor input) + diff ("lux f64 -" floored input)] + (cond ("lux f64 <" diff +0.5) + ("lux f64 +" +1.0 floored) + + ("lux f64 <" -0.5 diff) + ("lux f64 +" -1.0 floored) + + ## else + floored))) + +(def: #export (atan/2 x y) + (-> Frac Frac Frac) + (cond ("lux f64 <" x +0.0) + (..atan ("lux f64 /" x y)) + + ("lux f64 <" +0.0 x) + (if (or ("lux f64 <" y +0.0) + ("lux f64 =" +0.0 y)) + (|> y ("lux f64 /" x) atan ("lux f64 +" pi)) + (|> y ("lux f64 /" x) atan ("lux f64 -" pi))) + + ## ("lux f64 =" +0.0 x) + (cond ("lux f64 <" y +0.0) + (|> pi ("lux f64 /" +2.0)) + + ("lux f64 <" +0.0 y) + (|> pi ("lux f64 /" -2.0)) + + ## ("lux f64 =" +0.0 y) + ("lux f64 /" +0.0 +0.0)))) + +(def: #export (log' base input) + (-> Frac Frac Frac) + ("lux f64 /" + (..log base) + (..log input))) + +(def: #export (factorial n) + (-> Nat Nat) + (loop [acc 1 + n n] + (if (n.<= 1 n) + acc + (recur (n.* n acc) (dec n))))) + +(def: #export (hypotenuse catA catB) + (-> Frac Frac Frac) + (..pow +0.5 ("lux f64 +" + (..pow +2.0 catA) + (..pow +2.0 catB)))) + +## Hyperbolic functions +## https://en.wikipedia.org/wiki/Hyperbolic_function#Definitions +(template [<name> <comp> <inverse>] + [(def: #export (<name> x) + (-> Frac Frac) + (|> (..exp x) (<comp> (..exp ("lux f64 *" -1.0 x))) ("lux f64 /" +2.0))) + + (def: #export (<inverse> x) + (-> Frac Frac) + (|> +2.0 ("lux f64 /" (|> (..exp x) (<comp> (..exp ("lux f64 *" -1.0 x)))))))] + + [sinh "lux f64 -" csch] + [cosh "lux f64 +" sech] + ) + +(template [<name> <top> <bottom>] + [(def: #export (<name> x) + (-> Frac Frac) + (let [e+ (exp x) + e- (exp ("lux f64 *" -1.0 x)) + sinh' (|> e+ ("lux f64 -" e-)) + cosh' (|> e+ ("lux f64 +" e-))] + (|> <top> ("lux f64 /" <bottom>))))] + + [tanh sinh' cosh'] + [coth cosh' sinh'] + ) + +## https://en.wikipedia.org/wiki/Inverse_hyperbolic_functions#Definitions_in_terms_of_logarithms +(template [<name> <comp>] + [(def: #export (<name> x) + (-> Frac Frac) + (|> x (pow +2.0) (<comp> +1.0) (pow +0.5) ("lux f64 +" x) log))] + + [asinh "lux f64 +"] + [acosh "lux f64 -"] + ) + +(template [<name> <base> <diff>] + [(def: #export (<name> x) + (-> Frac Frac) + (let [x+ (|> <base> ("lux f64 +" <diff>)) + x- (|> <base> ("lux f64 -" <diff>))] + (|> x+ ("lux f64 /" x-) log ("lux f64 /" +2.0))))] + + [atanh +1.0 x] + [acoth x +1.0] + ) + +(template [<name> <op>] + [(def: #export (<name> x) + (-> Frac Frac) + (let [x^2 (|> x (pow +2.0))] + (|> +1.0 (<op> x^2) (pow +0.5) ("lux f64 +" +1.0) ("lux f64 /" x) log)))] + + [asech "lux f64 -"] + [acsch "lux f64 +"] + ) diff --git a/stdlib/source/library/lux/math/infix.lux b/stdlib/source/library/lux/math/infix.lux new file mode 100644 index 000000000..a8fd881aa --- /dev/null +++ b/stdlib/source/library/lux/math/infix.lux @@ -0,0 +1,96 @@ +(.module: {#.doc "Common mathematical constants and functions."} + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["<>" parser ("#\." functor) + ["<.>" code (#+ Parser)]]] + [data + ["." product] + [collection + ["." list ("#\." fold)]]] + [macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number + ["n" nat] + ["i" int]]]]]) + +(type: #rec Infix + (#Const Code) + (#Call (List Code)) + (#Unary Code Infix) + (#Binary Infix Code Infix)) + +(def: infix^ + (Parser Infix) + (<| <>.rec (function (_ infix^)) + ($_ <>.or + ($_ <>.either + (<>\map code.bit <code>.bit) + (<>\map code.nat <code>.nat) + (<>\map code.int <code>.int) + (<>\map code.rev <code>.rev) + (<>\map code.frac <code>.frac) + (<>\map code.text <code>.text) + (<>\map code.identifier <code>.identifier) + (<>\map code.tag <code>.tag)) + (<code>.form (<>.many <code>.any)) + (<code>.tuple (<>.and <code>.any infix^)) + (<code>.tuple ($_ <>.either + (do <>.monad + [_ (<code>.this! (' #and)) + init_subject infix^ + init_op <code>.any + init_param infix^ + steps (<>.some (<>.and <code>.any infix^))] + (wrap (product.right (list\fold (function (_ [op param] [subject [_subject _op _param]]) + [param [(#Binary _subject _op _param) + (` and) + (#Binary subject op param)]]) + [init_param [init_subject init_op init_param]] + steps)))) + (do <>.monad + [init_subject infix^ + init_op <code>.any + init_param infix^ + steps (<>.some (<>.and <code>.any infix^))] + (wrap (list\fold (function (_ [op param] [_subject _op _param]) + [(#Binary _subject _op _param) op param]) + [init_subject init_op init_param] + steps))) + )) + ))) + +(def: (to_prefix infix) + (-> Infix Code) + (case infix + (#Const value) + value + + (#Call parts) + (code.form parts) + + (#Unary op subject) + (` ((~ op) (~ (to_prefix subject)))) + + (#Binary left op right) + (` ((~ op) (~ (to_prefix right)) (~ (to_prefix left)))) + )) + +(syntax: #export (infix {expr infix^}) + {#.doc (doc "Infix math syntax." + (infix [x i.* +10]) + (infix [[x i.+ y] i.* [x i.- y]]) + (infix [sin [x i.+ y]]) + (infix [[x n.< y] and [y n.< z]]) + (infix [#and x n.< y n.< z]) + (infix [(n.* 3 9) gcd 450]) + + "The rules for infix syntax are simple." + "If you want your binary function to work well with it." + "Then take the argument to the right (y) as your first argument," + "and take the argument to the left (x) as your second argument.")} + (wrap (list (..to_prefix expr)))) diff --git a/stdlib/source/library/lux/math/logic/continuous.lux b/stdlib/source/library/lux/math/logic/continuous.lux new file mode 100644 index 000000000..631219671 --- /dev/null +++ b/stdlib/source/library/lux/math/logic/continuous.lux @@ -0,0 +1,40 @@ +(.module: + [library + [lux (#- false true or and not) + [abstract + [monoid (#+ Monoid)]] + [math + [number + ["r" rev ("#\." interval)]]]]]) + +(def: #export false Rev r\bottom) +(def: #export true Rev r\top) + +(template [<name> <chooser> <monoid> <identity>] + [(def: #export <name> + (-> Rev Rev Rev) + <chooser>) + + (implementation: #export <monoid> + (Monoid Rev) + + (def: identity <identity>) + (def: compose <name>))] + + [or r.max disjunction ..false] + [and r.min conjunction ..true] + ) + +(def: #export (not input) + (-> Rev Rev) + (r.- input ..true)) + +(def: #export (implies consequent antecedent) + (-> Rev Rev Rev) + (or (not antecedent) + consequent)) + +(def: #export (= left right) + (-> Rev Rev Rev) + (and (or (not left) right) + (or left (not right)))) diff --git a/stdlib/source/library/lux/math/logic/fuzzy.lux b/stdlib/source/library/lux/math/logic/fuzzy.lux new file mode 100644 index 000000000..c1815f3db --- /dev/null +++ b/stdlib/source/library/lux/math/logic/fuzzy.lux @@ -0,0 +1,132 @@ +(.module: + [library + [lux #* + [abstract + [predicate (#+ Predicate)] + [functor + ["." contravariant]]] + [data + [collection + ["." list] + ["." set (#+ Set)]]] + [math + [number + ["/" rev]]]]] + ["." // #_ + ["#" continuous]]) + +(type: #export (Fuzzy a) + (-> a Rev)) + +(implementation: #export functor + (contravariant.Functor Fuzzy) + + (def: (map f fb) + (|>> f fb))) + +(template [<name> <verdict>] + [(def: #export <name> + Fuzzy + (function (_ _) + <verdict>))] + + [empty //.false] + [full //.true] + ) + +(def: #export (membership set elem) + (All [a] (-> (Fuzzy a) a Rev)) + (set elem)) + +(template [<set_composition> <membership_composition>] + [(def: #export (<set_composition> left right) + (All [a] (-> (Fuzzy a) (Fuzzy a) (Fuzzy a))) + (function (_ elem) + (<membership_composition> (left elem) + (right elem))))] + + [union //.or] + [intersection //.and] + ) + +(def: #export (complement set) + (All [a] (-> (Fuzzy a) (Fuzzy a))) + (|>> set //.not)) + +(def: #export (difference sub base) + (All [a] (-> (Fuzzy a) (Fuzzy a) (Fuzzy a))) + (..intersection (..complement sub) base)) + +(def: #export (from_predicate predicate) + (All [a] (-> (Predicate a) (Fuzzy a))) + (function (_ elem) + (if (predicate elem) + //.true + //.false))) + +(def: #export (to_predicate treshold set) + (All [a] (-> Rev (Fuzzy a) (Predicate a))) + (function (_ elem) + (/.> treshold (set elem)))) + +(def: #export from_set + (All [a] (-> (Set a) (Fuzzy a))) + (|>> set.member? ..from_predicate)) + +(def: (ascending from to) + (-> Rev Rev (Fuzzy Rev)) + (let [measure (/.- from to)] + (function (_ elem) + (cond (/.< from elem) + ## below + //.false + + (/.< to elem) + ## in the middle... + (|> elem + (/.- from) + (/./ measure)) + + ## above + //.true)))) + +(def: (descending from to) + (-> Rev Rev (Fuzzy Rev)) + (..complement (..ascending from to))) + +(def: #export (gradient from to) + (-> Rev Rev (Fuzzy Rev)) + (if (/.< to from) + (..ascending from to) + (..descending from to))) + +(template: (!sort_2 <low> <high>) + (if (/.> <low> <high>) + [<low> <high>] + [<high> <low>])) + +(def: #export (triangle bottom middle top) + (-> Rev Rev Rev (Fuzzy Rev)) + (let [[low_0 high_0] (!sort_2 bottom middle) + [bottom' high_1] (!sort_2 low_0 top) + [middle' top'] (!sort_2 high_0 high_1)] + (..intersection (..ascending bottom' middle') + (..descending middle' top')))) + +(def: #export (trapezoid bottom middle_bottom middle_top top) + (-> Rev Rev Rev Rev (Fuzzy Rev)) + (let [[low_0 high_0] (!sort_2 bottom middle_bottom) + [low_1 high_1] (!sort_2 middle_top top) + [bottom' middle_0] (!sort_2 low_0 low_1) + [middle_1 top'] (!sort_2 high_0 high_1) + [middle_bottom' middle_top'] (!sort_2 middle_0 middle_1)] + (..intersection (..ascending bottom' middle_bottom') + (..descending middle_top' top')))) + +(def: #export (cut treshold set) + (All [a] (-> Rev (Fuzzy a) (Fuzzy a))) + (function (_ elem) + (let [membership (set elem)] + (if (/.< treshold membership) + //.false + (|> membership (/.- treshold) (/.* //.true)))))) diff --git a/stdlib/source/library/lux/math/modular.lux b/stdlib/source/library/lux/math/modular.lux new file mode 100644 index 000000000..679666580 --- /dev/null +++ b/stdlib/source/library/lux/math/modular.lux @@ -0,0 +1,157 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [monoid (#+ Monoid)] + [codec (#+ Codec)] + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" text (#+ Parser)] + ["<.>" code]]] + [data + ["." product] + ["." text ("#\." monoid)]] + [macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number + ["i" int ("#\." decimal)]]] + [type + abstract]]] + ["." // #_ + ["#" modulus (#+ Modulus)]]) + +(abstract: #export (Mod m) + {#modulus (Modulus m) + #value Int} + + {#.doc "A number under a modulus."} + + (def: #export (modular modulus value) + (All [%] (-> (Modulus %) Int (Mod %))) + (:abstraction {#modulus modulus + #value (i.mod (//.divisor modulus) value)})) + + (template [<name> <type> <side>] + [(def: #export <name> + (All [%] (-> (Mod %) <type>)) + (|>> :representation <side>))] + + [modulus (Modulus %) product.left] + [value Int product.right] + ) + + (exception: #export [%] (incorrect_modulus {modulus (Modulus %)} + {parsed Int}) + (exception.report + ["Expected" (i\encode (//.divisor modulus))] + ["Actual" (i\encode parsed)])) + + (def: separator + " mod ") + + (def: intL + (Parser Int) + (<>.codec i.decimal + (<text>.and (<text>.one_of "-+") (<text>.many <text>.decimal)))) + + (implementation: #export (codec expected) + (All [%] (-> (Modulus %) (Codec Text (Mod %)))) + + (def: (encode modular) + (let [[_ value] (:representation modular)] + ($_ text\compose + (i\encode value) + ..separator + (i\encode (//.divisor expected))))) + + (def: decode + (<text>.run + (do <>.monad + [[value _ actual] ($_ <>.and intL (<text>.this ..separator) intL) + _ (<>.assert (exception.construct ..incorrect_modulus [expected actual]) + (i.= (//.divisor expected) actual))] + (wrap (..modular expected value)))))) + + (template [<name> <op>] + [(def: #export (<name> reference subject) + (All [%] (-> (Mod %) (Mod %) Bit)) + (let [[_ reference] (:representation reference) + [_ subject] (:representation subject)] + (<op> reference subject)))] + + [= i.=] + [< i.<] + [<= i.<=] + [> i.>] + [>= i.>=] + ) + + (implementation: #export equivalence + (All [%] (Equivalence (Mod %))) + + (def: = ..=)) + + (implementation: #export order + (All [%] (Order (Mod %))) + + (def: &equivalence ..equivalence) + (def: < ..<)) + + (template [<name> <op>] + [(def: #export (<name> param subject) + (All [%] (-> (Mod %) (Mod %) (Mod %))) + (let [[modulus param] (:representation param) + [_ subject] (:representation subject)] + (:abstraction {#modulus modulus + #value (|> subject + (<op> param) + (i.mod (//.divisor modulus)))})))] + + [+ i.+] + [- i.-] + [* i.*] + ) + + (template [<composition> <identity> <monoid>] + [(implementation: #export (<monoid> modulus) + (All [%] (-> (Modulus %) (Monoid (Mod %)))) + + (def: identity + (..modular modulus <identity>)) + (def: compose + <composition>))] + + [..+ +0 addition] + [..* +1 multiplication] + ) + + (def: #export (inverse modular) + (All [%] (-> (Mod %) (Maybe (Mod %)))) + (let [[modulus value] (:representation modular) + [[vk mk] gcd] (i.extended_gcd value (//.divisor modulus))] + (case gcd + +1 (#.Some (..modular modulus vk)) + _ #.None))) + ) + +(exception: #export [r% s%] (moduli_are_not_equal {reference (Modulus r%)} + {subject (Modulus s%)}) + (exception.report + ["Reference" (i\encode (//.divisor reference))] + ["Subject" (i\encode (//.divisor subject))])) + +(def: #export (adapter reference subject) + (All [r% s%] + (-> (Modulus r%) (Modulus s%) + (Try (-> (Mod s%) (Mod r%))))) + (if (//.= reference subject) + (#try.Success (|>> ..value + (..modular reference))) + (exception.throw ..moduli_are_not_equal [reference subject]))) diff --git a/stdlib/source/library/lux/math/modulus.lux b/stdlib/source/library/lux/math/modulus.lux new file mode 100644 index 000000000..fa654a408 --- /dev/null +++ b/stdlib/source/library/lux/math/modulus.lux @@ -0,0 +1,56 @@ +(.module: + [library + [lux #* + ["." meta] + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + [parser + ["<.>" code]]] + [macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number + ["i" int]]] + [type + abstract]]]) + +(exception: #export zero_cannot_be_a_modulus) + +(abstract: #export (Modulus m) + Int + + {#.doc (doc "A number used as a modulus in modular arithmetic." + "It cannot be 0.")} + + (def: #export (modulus value) + (Ex [m] (-> Int (Try (Modulus m)))) + (if (i.= +0 value) + (exception.throw ..zero_cannot_be_a_modulus []) + (#try.Success (:abstraction value)))) + + (def: #export divisor + (All [m] (-> (Modulus m) Int)) + (|>> :representation)) + + (def: #export (= reference subject) + (All [r s] (-> (Modulus r) (Modulus s) Bit)) + (i.= (:representation reference) + (:representation subject))) + + (def: #export (congruent? modulus reference subject) + (All [m] (-> (Modulus m) Int Int Bit)) + (|> subject + (i.- reference) + (i.% (:representation modulus)) + (i.= +0))) + ) + +(syntax: #export (literal {divisor <code>.int}) + (meta.lift + (do try.monad + [_ (..modulus divisor)] + (wrap (list (` ((~! try.assume) (..modulus (~ (code.int divisor)))))))))) diff --git a/stdlib/source/library/lux/math/number.lux b/stdlib/source/library/lux/math/number.lux new file mode 100644 index 000000000..506fde750 --- /dev/null +++ b/stdlib/source/library/lux/math/number.lux @@ -0,0 +1,87 @@ +(.module: + [library + [lux #* + [abstract + [codec (#+ Codec)]] + [control + ["." try (#+ Try)]] + [data + ["." text]]]] + ["." / #_ + ["#." nat] + ["#." int] + ["#." rev] + ["#." frac]]) + +(macro: (encoding_doc tokens state) + (case tokens + (^ (list [location (#.Text encoding)] example_1 example_2)) + (let [encoding ($_ "lux text concat" + "Given syntax for a " + encoding + " number, generates a Nat, an Int, a Rev or a Frac.") + separators "Allows for the presence of commas among the digits." + description [location (#.Text ($_ "lux text concat" encoding " " separators))]] + (#try.Success [state (list (` (doc (~ description) + (~ example_1) + (~ example_2))))])) + + _ + (#try.Failure "Wrong syntax for 'encoding_doc'."))) + +(def: separator + ",") + +(def: (separator_prefixed? number) + (-> Text Bit) + (case ("lux text index" 0 ..separator number) + (#.Some 0) + #1 + + _ + #0)) + +(def: clean_separators + (-> Text Text) + (text.replace_all ..separator "")) + +(template [<macro> <nat> <int> <rev> <frac> <error> <doc>] + [(macro: #export (<macro> tokens state) + {#.doc <doc>} + (case tokens + (#.Cons [meta (#.Text repr')] #.Nil) + (if (..separator_prefixed? repr') + (#try.Failure <error>) + (let [repr (..clean_separators repr')] + (case (\ <nat> decode repr) + (#try.Success value) + (#try.Success [state (list [meta (#.Nat value)])]) + + (^multi (#try.Failure _) + [(\ <int> decode repr) (#try.Success value)]) + (#try.Success [state (list [meta (#.Int value)])]) + + (^multi (#try.Failure _) + [(\ <rev> decode repr) (#try.Success value)]) + (#try.Success [state (list [meta (#.Rev value)])]) + + (^multi (#try.Failure _) + [(\ <frac> decode repr) (#try.Success value)]) + (#try.Success [state (list [meta (#.Frac value)])]) + + _ + (#try.Failure <error>)))) + + _ + (#try.Failure <error>)))] + + [bin /nat.binary /int.binary /rev.binary /frac.binary + "Invalid binary syntax." + (encoding_doc "binary" (bin "11001001") (bin "11,00,10,01"))] + [oct /nat.octal /int.octal /rev.octal /frac.octal + "Invalid octal syntax." + (encoding_doc "octal" (oct "615243") (oct "615,243"))] + [hex /nat.hex /int.hex /rev.hex /frac.hex + "Invalid hexadecimal syntax." + (encoding_doc "hexadecimal" (hex "deadBEEF") (hex "dead,BEEF"))] + ) diff --git a/stdlib/source/library/lux/math/number/complex.lux b/stdlib/source/library/lux/math/number/complex.lux new file mode 100644 index 000000000..cc2c6a4f1 --- /dev/null +++ b/stdlib/source/library/lux/math/number/complex.lux @@ -0,0 +1,316 @@ +(.module: {#.doc "Complex arithmetic."} + [library + [lux #* + ["." math] + [abstract + [equivalence (#+ Equivalence)] + [codec (#+ Codec)] + ["M" monad (#+ Monad do)]] + [control + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." maybe] + [collection + ["." list ("#\." functor)]]] + [macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number + ["n" nat] + ["f" frac] + ["." int]]]]]) + +(type: #export Complex + {#real Frac + #imaginary Frac}) + +(syntax: #export (complex real {?imaginary (<>.maybe <code>.any)}) + {#.doc (doc "Complex literals." + (complex real imaginary) + "The imaginary part can be omitted if it's 0." + (complex real))} + (wrap (list (` {#..real (~ real) + #..imaginary (~ (maybe.default (' +0.0) + ?imaginary))})))) + +(def: #export i + (..complex +0.0 +1.0)) + +(def: #export +one + (..complex +1.0 +0.0)) + +(def: #export -one + (..complex -1.0 +0.0)) + +(def: #export zero + (..complex +0.0 +0.0)) + +(def: #export (not_a_number? complex) + (or (f.not_a_number? (get@ #real complex)) + (f.not_a_number? (get@ #imaginary complex)))) + +(def: #export (= param input) + (-> Complex Complex Bit) + (and (f.= (get@ #real param) + (get@ #real input)) + (f.= (get@ #imaginary param) + (get@ #imaginary input)))) + +(template [<name> <op>] + [(def: #export (<name> param input) + (-> Complex Complex Complex) + {#real (<op> (get@ #real param) + (get@ #real input)) + #imaginary (<op> (get@ #imaginary param) + (get@ #imaginary input))})] + + [+ f.+] + [- f.-] + ) + +(implementation: #export equivalence + (Equivalence Complex) + + (def: = ..=)) + +(template [<name> <transform>] + [(def: #export <name> + (-> Complex Complex) + (|>> (update@ #real <transform>) + (update@ #imaginary <transform>)))] + + [negate f.negate] + [signum f.signum] + ) + +(def: #export conjugate + (-> Complex Complex) + (update@ #imaginary f.negate)) + +(def: #export (*' param input) + (-> Frac Complex Complex) + {#real (f.* param + (get@ #real input)) + #imaginary (f.* param + (get@ #imaginary input))}) + +(def: #export (* param input) + (-> Complex Complex Complex) + {#real (f.- (f.* (get@ #imaginary param) + (get@ #imaginary input)) + (f.* (get@ #real param) + (get@ #real input))) + #imaginary (f.+ (f.* (get@ #real param) + (get@ #imaginary input)) + (f.* (get@ #imaginary param) + (get@ #real input)))}) + +(def: #export (/ param input) + (-> Complex Complex Complex) + (let [(^slots [#real #imaginary]) param] + (if (f.< (f.abs imaginary) + (f.abs real)) + (let [quot (f./ imaginary real) + denom (|> real (f.* quot) (f.+ imaginary))] + {#real (|> (get@ #real input) (f.* quot) (f.+ (get@ #imaginary input)) (f./ denom)) + #imaginary (|> (get@ #imaginary input) (f.* quot) (f.- (get@ #real input)) (f./ denom))}) + (let [quot (f./ real imaginary) + denom (|> imaginary (f.* quot) (f.+ real))] + {#real (|> (get@ #imaginary input) (f.* quot) (f.+ (get@ #real input)) (f./ denom)) + #imaginary (|> (get@ #imaginary input) (f.- (f.* quot (get@ #real input))) (f./ denom))})))) + +(def: #export (/' param subject) + (-> Frac Complex Complex) + (let [(^slots [#real #imaginary]) subject] + {#real (f./ param real) + #imaginary (f./ param imaginary)})) + +(def: #export (% param input) + (-> Complex Complex Complex) + (let [scaled (/ param input) + quotient (|> scaled + (update@ #real math.floor) + (update@ #imaginary math.floor))] + (- (* quotient param) + input))) + +(def: #export (cos subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject] + {#real (f.* (math.cosh imaginary) + (math.cos real)) + #imaginary (f.negate (f.* (math.sinh imaginary) + (math.sin real)))})) + +(def: #export (cosh subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject] + {#real (f.* (math.cos imaginary) + (math.cosh real)) + #imaginary (f.* (math.sin imaginary) + (math.sinh real))})) + +(def: #export (sin subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject] + {#real (f.* (math.cosh imaginary) + (math.sin real)) + #imaginary (f.* (math.sinh imaginary) + (math.cos real))})) + +(def: #export (sinh subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject] + {#real (f.* (math.cos imaginary) + (math.sinh real)) + #imaginary (f.* (math.sin imaginary) + (math.cosh real))})) + +(def: #export (tan subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject + r2 (f.* +2.0 real) + i2 (f.* +2.0 imaginary) + d (f.+ (math.cos r2) (math.cosh i2))] + {#real (f./ d (math.sin r2)) + #imaginary (f./ d (math.sinh i2))})) + +(def: #export (tanh subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject + r2 (f.* +2.0 real) + i2 (f.* +2.0 imaginary) + d (f.+ (math.cosh r2) (math.cos i2))] + {#real (f./ d (math.sinh r2)) + #imaginary (f./ d (math.sin i2))})) + +(def: #export (abs subject) + (-> Complex Frac) + (let [(^slots [#real #imaginary]) subject] + (if (f.< (f.abs imaginary) + (f.abs real)) + (if (f.= +0.0 imaginary) + (f.abs real) + (let [q (f./ imaginary real)] + (f.* (math.pow +0.5 (f.+ +1.0 (f.* q q))) + (f.abs imaginary)))) + (if (f.= +0.0 real) + (f.abs imaginary) + (let [q (f./ real imaginary)] + (f.* (math.pow +0.5 (f.+ +1.0 (f.* q q))) + (f.abs real))))))) + +(def: #export (exp subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject + r_exp (math.exp real)] + {#real (f.* r_exp (math.cos imaginary)) + #imaginary (f.* r_exp (math.sin imaginary))})) + +(def: #export (log subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject] + {#real (|> subject ..abs math.log) + #imaginary (math.atan/2 real imaginary)})) + +(template [<name> <type> <op>] + [(def: #export (<name> param input) + (-> <type> Complex Complex) + (|> input log (<op> param) exp))] + + [pow Complex ..*] + [pow' Frac ..*'] + ) + +(def: (copy_sign sign magnitude) + (-> Frac Frac Frac) + (f.* (f.signum sign) magnitude)) + +(def: #export (root/2 input) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) input + t (|> input ..abs (f.+ (f.abs real)) (f./ +2.0) (math.pow +0.5))] + (if (f.>= +0.0 real) + {#real t + #imaginary (f./ (f.* +2.0 t) + imaginary)} + {#real (f./ (f.* +2.0 t) + (f.abs imaginary)) + #imaginary (f.* t (..copy_sign imaginary +1.0))}))) + +(def: (root/2-1z input) + (-> Complex Complex) + (|> (complex +1.0) (- (* input input)) ..root/2)) + +(def: #export (reciprocal (^slots [#real #imaginary])) + (-> Complex Complex) + (if (f.< (f.abs imaginary) + (f.abs real)) + (let [q (f./ imaginary real) + scale (f./ (|> real (f.* q) (f.+ imaginary)) + +1.0)] + {#real (f.* q scale) + #imaginary (f.negate scale)}) + (let [q (f./ real imaginary) + scale (f./ (|> imaginary (f.* q) (f.+ real)) + +1.0)] + {#real scale + #imaginary (|> scale f.negate (f.* q))}))) + +(def: #export (acos input) + (-> Complex Complex) + (|> input + (..+ (|> input ..root/2-1z (..* ..i))) + ..log + (..* (..negate ..i)))) + +(def: #export (asin input) + (-> Complex Complex) + (|> input + ..root/2-1z + (..+ (..* ..i input)) + ..log + (..* (..negate ..i)))) + +(def: #export (atan input) + (-> Complex Complex) + (|> input + (..+ ..i) + (../ (..- input ..i)) + ..log + (..* (../ (..complex +2.0) ..i)))) + +(def: #export (argument (^slots [#real #imaginary])) + (-> Complex Frac) + (math.atan/2 real imaginary)) + +(def: #export (roots nth input) + (-> Nat Complex (List Complex)) + (if (n.= 0 nth) + (list) + (let [r_nth (|> nth .int int.frac) + nth_root_of_abs (|> input ..abs (math.pow (f./ r_nth +1.0))) + nth_phi (|> input ..argument (f./ r_nth)) + slice (|> math.pi (f.* +2.0) (f./ r_nth))] + (|> (list.indices nth) + (list\map (function (_ nth') + (let [inner (|> nth' .int int.frac + (f.* slice) + (f.+ nth_phi)) + real (f.* nth_root_of_abs + (math.cos inner)) + imaginary (f.* nth_root_of_abs + (math.sin inner))] + {#real real + #imaginary imaginary}))))))) + +(def: #export (approximately? margin_of_error standard value) + (-> Frac Complex Complex Bit) + (and (f.approximately? margin_of_error + (get@ #..real standard) + (get@ #..real value)) + (f.approximately? margin_of_error + (get@ #..imaginary standard) + (get@ #..imaginary value)))) diff --git a/stdlib/source/library/lux/math/number/frac.lux b/stdlib/source/library/lux/math/number/frac.lux new file mode 100644 index 000000000..f6f01192e --- /dev/null +++ b/stdlib/source/library/lux/math/number/frac.lux @@ -0,0 +1,447 @@ +(.module: + [library + [lux (#- nat int rev) + ["@" target] + [abstract + [hash (#+ Hash)] + [monoid (#+ Monoid)] + [equivalence (#+ Equivalence)] + [codec (#+ Codec)] + [predicate (#+ Predicate)] + [order (#+ Order)] + [monad (#+ do)]] + [control + ["." try (#+ Try)]] + [data + ["." maybe] + ["." text]]]] + ["." // #_ + ["#." i64] + ["#." nat] + ["#." int] + ["#." rev] + ["/#" //]]) + +(def: #export (= reference sample) + {#.doc "Frac(tion) equivalence."} + (-> Frac Frac Bit) + ("lux f64 =" reference sample)) + +(def: #export (< reference sample) + {#.doc "Frac(tion) less-than."} + (-> Frac Frac Bit) + ("lux f64 <" reference sample)) + +(def: #export (<= reference sample) + {#.doc "Frac(tion) less-than or equal."} + (-> Frac Frac Bit) + (or ("lux f64 <" reference sample) + ("lux f64 =" reference sample))) + +(def: #export (> reference sample) + {#.doc "Frac(tion) greater-than."} + (-> Frac Frac Bit) + ("lux f64 <" sample reference)) + +(def: #export (>= reference sample) + {#.doc "Frac(tion) greater-than or equal."} + (-> Frac Frac Bit) + (or ("lux f64 <" sample reference) + ("lux f64 =" sample reference))) + +(template [<comparison> <name>] + [(def: #export <name> + (Predicate Frac) + (<comparison> +0.0))] + + [..> positive?] + [..< negative?] + [..= zero?] + ) + +(template [<name> <op> <doc>] + [(def: #export (<name> param subject) + {#.doc <doc>} + (-> Frac Frac Frac) + (<op> param subject))] + + [+ "lux f64 +" "Frac(tion) addition."] + [- "lux f64 -" "Frac(tion) substraction."] + [* "lux f64 *" "Frac(tion) multiplication."] + [/ "lux f64 /" "Frac(tion) division."] + [% "lux f64 %" "Frac(tion) remainder."] + ) + +(def: #export (/% param subject) + (-> Frac Frac [Frac Frac]) + [(../ param subject) + (..% param subject)]) + +(def: #export negate + (-> Frac Frac) + (..* -1.0)) + +(def: #export (abs x) + (-> Frac Frac) + (if (..< +0.0 x) + (..* -1.0 x) + x)) + +(def: #export (signum x) + (-> Frac Frac) + (cond (..= +0.0 x) +0.0 + (..< +0.0 x) -1.0 + ## else + +1.0)) + +(def: min_exponent -1022) +(def: max_exponent (//int.frac +1023)) + +(template [<name> <test> <doc>] + [(def: #export (<name> left right) + {#.doc <doc>} + (-> Frac Frac Frac) + (if (<test> right left) + left + right))] + + [min ..< "Frac(tion) minimum."] + [max ..> "Frac(tion) minimum."] + ) + +(def: #export nat + (-> Frac Nat) + (|>> "lux f64 i64" .nat)) + +(def: #export int + (-> Frac Int) + (|>> "lux f64 i64")) + +(def: mantissa_size Nat 52) +(def: exponent_size Nat 11) + +(def: frac_denominator + (|> -1 + ("lux i64 right-shift" ..exponent_size) + "lux i64 f64")) + +(def: #export rev + (-> Frac Rev) + (|>> ..abs + (..% +1.0) + (..* ..frac_denominator) + "lux f64 i64" + ("lux i64 left-shift" ..exponent_size))) + +(implementation: #export equivalence + (Equivalence Frac) + + (def: = ..=)) + +(implementation: #export order + (Order Frac) + + (def: &equivalence ..equivalence) + (def: < ..<)) + +(def: #export smallest + Frac + (///.pow (//int.frac (//int.- (.int ..mantissa_size) ..min_exponent)) + +2.0)) + +(def: #export biggest + Frac + (let [f2^-52 (///.pow (//nat.frac (//nat.- ..mantissa_size 0)) +2.0) + f2^+1023 (///.pow ..max_exponent +2.0)] + (|> +2.0 + (..- f2^-52) + (..* f2^+1023)))) + +(template [<name> <compose> <identity>] + [(implementation: #export <name> + (Monoid Frac) + + (def: identity <identity>) + (def: compose <compose>))] + + [addition ..+ +0.0] + [multiplication ..* +1.0] + [minimum ..min ..biggest] + [maximum ..max (..* -1.0 ..biggest)] + ) + +(template [<name> <numerator> <doc>] + [(def: #export <name> + {#.doc <doc>} + Frac + (../ +0.0 <numerator>))] + + [not_a_number +0.0 "Not a number."] + [positive_infinity +1.0 "Positive infinity."] + ) + +(def: #export negative_infinity + {#.doc "Negative infinity."} + Frac + (..* -1.0 ..positive_infinity)) + +(def: #export (not_a_number? number) + {#.doc "Tests whether a frac is actually not-a-number."} + (-> Frac Bit) + (not (..= number number))) + +(def: #export (number? value) + (-> Frac Bit) + (not (or (..not_a_number? value) + (..= ..positive_infinity value) + (..= ..negative_infinity value)))) + +(implementation: #export decimal + (Codec Text Frac) + + (def: (encode x) + (case x + -0.0 (let [output ("lux f64 encode" x)] + (if (text.starts_with? "-" output) + output + ("lux text concat" "+" output))) + _ (if (..< +0.0 x) + ("lux f64 encode" x) + ("lux text concat" "+" ("lux f64 encode" x))))) + + (def: (decode input) + (case ("lux f64 decode" [input]) + (#.Some value) + (#try.Success value) + + #.None + (#try.Failure "Could not decode Frac")))) + +(def: log/2 + (-> Frac Frac) + (|>> ///.log + (../ (///.log +2.0)))) + +(def: double_bias Nat 1023) + +(def: exponent_mask (//i64.mask ..exponent_size)) + +(def: exponent_offset ..mantissa_size) +(def: sign_offset (//nat.+ ..exponent_size ..exponent_offset)) + +(template [<cast> <hex> <name>] + [(def: <name> (|> <hex> (\ //nat.hex decode) try.assume <cast>))] + + [.i64 "FFF8000000000000" not_a_number_bits] + [.i64 "7FF0000000000000" positive_infinity_bits] + [.i64 "FFF0000000000000" negative_infinity_bits] + [.i64 "0000000000000000" positive_zero_bits] + [.i64 "8000000000000000" negative_zero_bits] + [.nat "7FF" special_exponent_bits] + ) + +(def: smallest_exponent + (..log/2 ..smallest)) + +(def: #export (to_bits input) + (-> Frac I64) + (.i64 (cond (..not_a_number? input) + ..not_a_number_bits + + (..= positive_infinity input) + ..positive_infinity_bits + + (..= negative_infinity input) + ..negative_infinity_bits + + (..= +0.0 input) + (let [reciprocal (../ input +1.0)] + (if (..= positive_infinity reciprocal) + ## Positive zero + ..positive_zero_bits + ## Negative zero + ..negative_zero_bits)) + + ## else + (let [sign_bit (if (..< -0.0 input) + 1 + 0) + input (..abs input) + exponent (|> input + ..log/2 + ///.floor + (..min ..max_exponent)) + min_gap (..- (//int.frac ..min_exponent) exponent) + power (|> (//nat.frac ..mantissa_size) + (..+ (..min +0.0 min_gap)) + (..- exponent)) + max_gap (..- ..max_exponent power) + mantissa (|> input + (..* (///.pow (..min ..max_exponent power) +2.0)) + (..* (if (..> +0.0 max_gap) + (///.pow max_gap +2.0) + +1.0))) + exponent_bits (|> (if (..< +0.0 min_gap) + (|> (..int exponent) + (//int.- (..int min_gap)) + dec) + (..int exponent)) + (//int.+ (.int ..double_bias)) + (//i64.and ..exponent_mask)) + mantissa_bits (..int mantissa)] + ($_ //i64.or + (//i64.left_shift ..sign_offset sign_bit) + (//i64.left_shift ..exponent_offset exponent_bits) + (//i64.clear ..mantissa_size mantissa_bits))) + ))) + +(template [<getter> <size> <offset>] + [(def: <getter> + (-> (I64 Any) I64) + (let [mask (|> 1 (//i64.left_shift <size>) dec (//i64.left_shift <offset>))] + (|>> (//i64.and mask) (//i64.right_shift <offset>) .i64)))] + + [mantissa ..mantissa_size 0] + [exponent ..exponent_size ..mantissa_size] + [sign 1 ..sign_offset] + ) + +(def: #export (from_bits input) + (-> I64 Frac) + (case [(: Nat (..exponent input)) + (: Nat (..mantissa input)) + (: Nat (..sign input))] + (^ [(static ..special_exponent_bits) 0 0]) + ..positive_infinity + + (^ [(static ..special_exponent_bits) 0 1]) + ..negative_infinity + + (^ [(static ..special_exponent_bits) _ _]) + ..not_a_number + + ## Positive zero + [0 0 0] +0.0 + ## Negative zero + [0 0 1] (..* -1.0 +0.0) + + [E M S] + (let [sign (if (//nat.= 0 S) + +1.0 + -1.0) + [mantissa power] (if (//nat.< ..mantissa_size E) + [(if (//nat.= 0 E) + M + (//i64.set ..mantissa_size M)) + (|> E + (//nat.- ..double_bias) + .int + (//int.max ..min_exponent) + (//int.- (.int ..mantissa_size)))] + [(//i64.set ..mantissa_size M) + (|> E (//nat.- ..double_bias) (//nat.- ..mantissa_size) .int)]) + exponent (///.pow (//int.frac power) +2.0)] + (|> (//nat.frac mantissa) + (..* exponent) + (..* sign))))) + +(def: (split_exponent codec representation) + (-> (Codec Text Nat) Text (Try [Text Int])) + (case [("lux text index" 0 "e+" representation) + ("lux text index" 0 "E+" representation) + ("lux text index" 0 "e-" representation) + ("lux text index" 0 "E-" representation)] + (^template [<factor> <patterns>] + [<patterns> + (do try.monad + [#let [after_offset (//nat.+ 2 split_index) + after_length (//nat.- after_offset ("lux text size" representation))] + exponent (|> representation + ("lux text clip" after_offset after_length) + (\ codec decode))] + (wrap [("lux text clip" 0 split_index representation) + (//int.* <factor> (.int exponent))]))]) + ([+1 (^or [(#.Some split_index) #.None #.None #.None] + [#.None (#.Some split_index) #.None #.None])] + [-1 (^or [#.None #.None (#.Some split_index) #.None] + [#.None #.None #.None (#.Some split_index)])]) + + _ + (#try.Success [representation +0]))) + +(template [<struct> <nat> <int> <error>] + [(implementation: #export <struct> + (Codec Text Frac) + + (def: (encode value) + (let [bits (..to_bits value) + mantissa (..mantissa bits) + exponent (//int.- (.int ..double_bias) (..exponent bits)) + sign (..sign bits)] + ($_ "lux text concat" + (case (.nat sign) + 1 "-" + 0 "+" + _ (undefined)) + (\ <nat> encode (.nat mantissa)) + ".0E" + (\ <int> encode exponent)))) + + (def: (decode representation) + (let [negative? (text.starts_with? "-" representation) + positive? (text.starts_with? "+" representation)] + (if (or negative? positive?) + (do {! try.monad} + [[mantissa exponent] (..split_exponent <nat> representation) + [whole decimal] (case ("lux text index" 0 "." mantissa) + (#.Some split_index) + (do ! + [#let [after_offset (inc split_index) + after_length (//nat.- after_offset ("lux text size" mantissa))] + decimal (|> mantissa + ("lux text clip" after_offset after_length) + (\ <nat> decode))] + (wrap [("lux text clip" 0 split_index mantissa) + decimal])) + + #.None + (#try.Failure ("lux text concat" <error> representation))) + #let [whole ("lux text clip" 1 (dec ("lux text size" whole)) whole)] + mantissa (\ <nat> decode (case decimal + 0 whole + _ ("lux text concat" whole (\ <nat> encode decimal)))) + #let [sign (if negative? 1 0)]] + (wrap (..from_bits + ($_ //i64.or + (//i64.left_shift ..sign_offset (.i64 sign)) + (//i64.left_shift ..mantissa_size (.i64 (//int.+ (.int ..double_bias) exponent))) + (//i64.clear ..mantissa_size (.i64 mantissa)))))) + (#try.Failure ("lux text concat" <error> representation))))))] + + [binary //nat.binary //int.binary "Invalid binary syntax: "] + [octal //nat.octal //int.octal "Invalid octaladecimal syntax: "] + [hex //nat.hex //int.hex "Invalid hexadecimal syntax: "] + ) + +(implementation: #export hash + (Hash Frac) + + (def: &equivalence ..equivalence) + (def: hash ..to_bits)) + +(def: #export (approximately? margin_of_error standard value) + (-> Frac Frac Frac Bit) + (|> value + (..- standard) + ..abs + (..< margin_of_error))) + +(def: #export (mod divisor dividend) + (All [m] (-> Frac Frac Frac)) + (let [remainder (..% divisor dividend)] + (if (or (and (..< +0.0 divisor) + (..> +0.0 remainder)) + (and (..> +0.0 divisor) + (..< +0.0 remainder))) + (..+ divisor remainder) + remainder))) diff --git a/stdlib/source/library/lux/math/number/i16.lux b/stdlib/source/library/lux/math/number/i16.lux new file mode 100644 index 000000000..a35300c11 --- /dev/null +++ b/stdlib/source/library/lux/math/number/i16.lux @@ -0,0 +1,24 @@ +(.module: + [library + [lux (#- i64) + [abstract + [equivalence (#+ Equivalence)]] + [data + ["." maybe]] + [type (#+ :by_example)]]] + [// + ["." i64 (#+ Sub)]]) + +(def: sub (maybe.assume (i64.sub 16))) + +(def: #export I16 + (:by_example [size] + (Sub size) + ..sub + + (I64 size))) + +(def: #export equivalence (Equivalence I16) (\ ..sub &equivalence)) +(def: #export width Nat (\ ..sub width)) +(def: #export i16 (-> I64 I16) (\ ..sub narrow)) +(def: #export i64 (-> I16 I64) (\ ..sub widen)) diff --git a/stdlib/source/library/lux/math/number/i32.lux b/stdlib/source/library/lux/math/number/i32.lux new file mode 100644 index 000000000..a0ecfabc2 --- /dev/null +++ b/stdlib/source/library/lux/math/number/i32.lux @@ -0,0 +1,24 @@ +(.module: + [library + [lux (#- i64) + [abstract + [equivalence (#+ Equivalence)]] + [data + ["." maybe]] + [type (#+ :by_example)]]] + [// + ["." i64 (#+ Sub)]]) + +(def: sub (maybe.assume (i64.sub 32))) + +(def: #export I32 + (:by_example [size] + (Sub size) + ..sub + + (I64 size))) + +(def: #export equivalence (Equivalence I32) (\ ..sub &equivalence)) +(def: #export width Nat (\ ..sub width)) +(def: #export i32 (-> I64 I32) (\ ..sub narrow)) +(def: #export i64 (-> I32 I64) (\ ..sub widen)) diff --git a/stdlib/source/library/lux/math/number/i64.lux b/stdlib/source/library/lux/math/number/i64.lux new file mode 100644 index 000000000..357b36557 --- /dev/null +++ b/stdlib/source/library/lux/math/number/i64.lux @@ -0,0 +1,214 @@ +(.module: + [library + [lux (#- and or not false true) + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + [monoid (#+ Monoid)]] + [control + ["." try]]]] + [// + ["n" nat]]) + +(def: #export bits_per_byte + 8) + +(def: #export bytes_per_i64 + 8) + +(def: #export width + Nat + (n.* ..bits_per_byte + ..bytes_per_i64)) + +(template [<parameter_type> <name> <op> <doc>] + [(def: #export (<name> parameter subject) + {#.doc <doc>} + (All [s] (-> <parameter_type> (I64 s) (I64 s))) + (<op> parameter subject))] + + [(I64 Any) or "lux i64 or" "Bitwise or."] + [(I64 Any) xor "lux i64 xor" "Bitwise xor."] + [(I64 Any) and "lux i64 and" "Bitwise and."] + + [Nat left_shift "lux i64 left-shift" "Bitwise left-shift."] + [Nat right_shift "lux i64 right-shift" "Unsigned/logic bitwise right-shift."] + ) + +(type: #export Mask + I64) + +(def: #export (bit position) + (-> Nat Mask) + (|> 1 .i64 (..left_shift (n.% ..width position)))) + +(def: #export sign + Mask + (..bit (dec ..width))) + +(def: #export not + {#.doc "Bitwise negation."} + (All [s] (-> (I64 s) (I64 s))) + (..xor (.i64 (dec 0)))) + +(def: #export false + Mask + (.i64 0)) + +(def: #export true + Mask + (..not ..false)) + +(def: #export (mask amount_of_bits) + (-> Nat Mask) + (case amount_of_bits + 0 ..false + bits (case (n.% ..width bits) + 0 ..true + bits (|> 1 .i64 (..left_shift (n.% ..width bits)) .dec)))) + +(def: (add_shift shift value) + (-> Nat Nat Nat) + (|> value (right_shift shift) (n.+ value))) + +(def: #export (count subject) + {#.doc "Count the number of 1s in a bit-map."} + (-> (I64 Any) Nat) + (let [count' (n.- (|> subject (right_shift 1) (..and 6148914691236517205) i64) + (i64 subject))] + (|> count' + (right_shift 2) (..and 3689348814741910323) (n.+ (..and 3689348814741910323 count')) + (add_shift 4) (..and 1085102592571150095) + (add_shift 8) + (add_shift 16) + (add_shift 32) + (..and 127)))) + +(def: #export (clear idx input) + {#.doc "Clear bit at given index."} + (All [s] (-> Nat (I64 s) (I64 s))) + (|> idx ..bit ..not (..and input))) + +(template [<name> <op> <doc>] + [(def: #export (<name> idx input) + {#.doc <doc>} + (All [s] (-> Nat (I64 s) (I64 s))) + (|> idx ..bit (<op> input)))] + + [set ..or "Set bit at given index."] + [flip ..xor "Flip bit at given index."] + ) + +(def: #export (set? idx input) + (-> Nat (I64 Any) Bit) + (|> input (:as I64) (..and (..bit idx)) (n.= 0) .not)) + +(def: #export (clear? idx input) + (-> Nat (I64 Any) Bit) + (.not (..set? idx input))) + +(template [<name> <forward> <backward>] + [(def: #export (<name> distance input) + (All [s] (-> Nat (I64 s) (I64 s))) + (..or (<forward> distance input) + (<backward> (n.- (n.% ..width distance) ..width) input)))] + + [rotate_left ..left_shift ..right_shift] + [rotate_right ..right_shift ..left_shift] + ) + +(def: #export (region size offset) + (-> Nat Nat Mask) + (..left_shift offset (..mask size))) + +(implementation: #export equivalence + (All [a] (Equivalence (I64 a))) + + (def: (= reference sample) + ("lux i64 =" reference sample))) + +(implementation: #export hash + (All [a] (Hash (I64 a))) + + (def: &equivalence ..equivalence) + + (def: hash .nat)) + +(template [<monoid> <identity> <compose>] + [(implementation: #export <monoid> + (All [a] (Monoid (I64 a))) + + (def: identity <identity>) + (def: compose <compose>))] + + [disjunction ..false ..or] + [conjunction ..true ..and] + ) + +(def: #export reverse + (All [a] (-> (I64 a) (I64 a))) + (let [swapper (: (-> Nat (All [a] (-> (I64 a) (I64 a)))) + (function (_ power) + (let [size (..left_shift power 1) + repetitions (: (-> Nat Text Text) + (function (_ times char) + (loop [iterations 1 + output char] + (if (n.< times iterations) + (recur (inc iterations) + ("lux text concat" char output)) + output)))) + pattern (repetitions (n./ (n.+ size size) ..width) + ("lux text concat" + (repetitions size "1") + (repetitions size "0"))) + + high (try.assume (\ n.binary decode pattern)) + low (..rotate_right size high)] + (function (_ value) + (..or (..right_shift size (..and high value)) + (..left_shift size (..and low value))))))) + + swap/01 (swapper 0) + swap/02 (swapper 1) + swap/04 (swapper 2) + swap/08 (swapper 3) + swap/16 (swapper 4) + swap/32 (swapper 5)] + (|>> swap/32 + swap/16 + swap/08 + swap/04 + swap/02 + swap/01))) + +(interface: #export (Sub size) + (: (Equivalence (I64 size)) + &equivalence) + (: Nat + width) + (: (-> I64 (I64 size)) + narrow) + (: (-> (I64 size) I64) + widen)) + +(def: #export (sub width) + (Ex [size] (-> Nat (Maybe (Sub size)))) + (if (.and (n.> 0 width) + (n.< ..width width)) + (let [sign_shift (n.- width ..width) + sign (..bit (dec width)) + mantissa (..mask (dec width)) + co_mantissa (..xor (.i64 -1) mantissa)] + (#.Some (: Sub + (implementation + (def: &equivalence ..equivalence) + (def: width width) + (def: (narrow value) + (..or (|> value (..and ..sign) (..right_shift sign_shift)) + (|> value (..and mantissa)))) + (def: (widen value) + (.i64 (case (.nat (..and sign value)) + 0 value + _ (..or co_mantissa value)))))))) + #.None)) diff --git a/stdlib/source/library/lux/math/number/i8.lux b/stdlib/source/library/lux/math/number/i8.lux new file mode 100644 index 000000000..2e8fc0cf1 --- /dev/null +++ b/stdlib/source/library/lux/math/number/i8.lux @@ -0,0 +1,24 @@ +(.module: + [library + [lux (#- i64) + [abstract + [equivalence (#+ Equivalence)]] + [data + ["." maybe]] + [type (#+ :by_example)]]] + [// + ["." i64 (#+ Sub)]]) + +(def: sub (maybe.assume (i64.sub 8))) + +(def: #export I8 + (:by_example [size] + (Sub size) + ..sub + + (I64 size))) + +(def: #export equivalence (Equivalence I8) (\ ..sub &equivalence)) +(def: #export width Nat (\ ..sub width)) +(def: #export i8 (-> I64 I8) (\ ..sub narrow)) +(def: #export i64 (-> I8 I64) (\ ..sub widen)) diff --git a/stdlib/source/library/lux/math/number/int.lux b/stdlib/source/library/lux/math/number/int.lux new file mode 100644 index 000000000..c72c31e16 --- /dev/null +++ b/stdlib/source/library/lux/math/number/int.lux @@ -0,0 +1,260 @@ +(.module: + [library + [lux #* + [abstract + [hash (#+ Hash)] + [enum (#+ Enum)] + [interval (#+ Interval)] + [monoid (#+ Monoid)] + [equivalence (#+ Equivalence)] + [codec (#+ Codec)] + [predicate (#+ Predicate)] + ["." order (#+ Order)]] + [control + ["." try (#+ Try)]] + [data + [text (#+ Char)] + ["." maybe]]]] + ["." // #_ + ["#." nat] + ["#." i64]]) + +(def: #export (= reference sample) + {#.doc "Int(eger) equivalence."} + (-> Int Int Bit) + ("lux i64 =" reference sample)) + +(def: #export (< reference sample) + {#.doc "Int(eger) less-than."} + (-> Int Int Bit) + ("lux i64 <" reference sample)) + +(def: #export (<= reference sample) + {#.doc "Int(eger) less-than or equal."} + (-> Int Int Bit) + (if ("lux i64 <" reference sample) + #1 + ("lux i64 =" reference sample))) + +(def: #export (> reference sample) + {#.doc "Int(eger) greater-than."} + (-> Int Int Bit) + ("lux i64 <" sample reference)) + +(def: #export (>= reference sample) + {#.doc "Int(eger) greater-than or equal."} + (-> Int Int Bit) + (if ("lux i64 <" sample reference) + #1 + ("lux i64 =" reference sample))) + +(template [<comparison> <name>] + [(def: #export <name> + (Predicate Int) + (<comparison> +0))] + + [..> positive?] + [..< negative?] + [..= zero?] + ) + +(template [<name> <test> <doc>] + [(def: #export (<name> left right) + {#.doc <doc>} + (-> Int Int Int) + (if (<test> right left) + left + right))] + + [min ..< "Int(eger) minimum."] + [max ..> "Int(eger) maximum."] + ) + +(template [<name> <op> <doc>] + [(def: #export (<name> param subject) + {#.doc <doc>} + (-> Int Int Int) + (<op> param subject))] + + [+ "lux i64 +" "Int(eger) addition."] + [- "lux i64 -" "Int(eger) substraction."] + [* "lux i64 *" "Int(eger) multiplication."] + [/ "lux i64 /" "Int(eger) division."] + [% "lux i64 %" "Int(eger) remainder."] + ) + +(def: #export (/% param subject) + (-> Int Int [Int Int]) + [(../ param subject) + (..% param subject)]) + +(def: #export (negate value) + (-> Int Int) + (..- value +0)) + +(def: #export (abs x) + (-> Int Int) + (if (..< +0 x) + (..* -1 x) + x)) + +(def: #export (signum x) + (-> Int Int) + (cond (..= +0 x) +0 + (..< +0 x) -1 + ## else + +1)) + +## https://rob.conery.io/2018/08/21/mod-and-remainder-are-not-the-same/ +(def: #export (mod divisor dividend) + (All [m] (-> Int Int Int)) + (let [remainder (..% divisor dividend)] + (if (or (and (..< +0 divisor) + (..> +0 remainder)) + (and (..> +0 divisor) + (..< +0 remainder))) + (..+ divisor remainder) + remainder))) + +(def: #export even? + (-> Int Bit) + (|>> (..% +2) ("lux i64 =" +0))) + +(def: #export odd? + (-> Int Bit) + (|>> ..even? not)) + +(def: #export (gcd a b) + {#.doc "Greatest Common Divisor."} + (-> Int Int Int) + (case b + +0 a + _ (gcd b (..% b a)))) + +(def: #export (co-prime? a b) + (-> Int Int Bit) + (..= +1 (..gcd a b))) + +## https://en.wikipedia.org/wiki/Extended_Euclidean_algorithm +(def: #export (extended_gcd a b) + {#.doc "Extended euclidean algorithm."} + (-> Int Int [[Int Int] Int]) + (loop [x +1 x1 +0 + y +0 y1 +1 + a1 a b1 b] + (case b1 + +0 [[x y] a1] + _ (let [q (/ b1 a1)] + (recur x1 (- (* q x1) x) + y1 (- (* q y1) y) + b1 (- (* q b1) a1)))))) + +(def: #export (lcm a b) + {#.doc "Least Common Multiple."} + (-> Int Int Int) + (case [a b] + (^or [_ +0] [+0 _]) + +0 + + _ + (|> a (/ (gcd a b)) (* b)) + )) + +(def: #export frac + (-> Int Frac) + (|>> "lux i64 f64")) + +(implementation: #export equivalence + (Equivalence Int) + + (def: = ..=)) + +(implementation: #export order + (Order Int) + + (def: &equivalence ..equivalence) + (def: < ..<)) + +(implementation: #export enum + (Enum Int) + + (def: &order ..order) + (def: succ inc) + (def: pred dec)) + +## TODO: Find out why the numeric literals fail during JS compilation. +(implementation: #export interval + (Interval Int) + + (def: &enum ..enum) + (def: top + ## +9,223,372,036,854,775,807 + (let [half (//i64.left_shift 62 +1)] + (+ half + (dec half)))) + (def: bottom + ## -9,223,372,036,854,775,808 + (//i64.left_shift 63 +1))) + +(template [<name> <compose> <identity>] + [(implementation: #export <name> + (Monoid Int) + + (def: identity <identity>) + (def: compose <compose>))] + + [addition ..+ +0] + [multiplication ..* +1] + [maximum ..max (\ ..interval bottom)] + [minimum ..min (\ ..interval top)] + ) + +(def: -sign "-") +(def: +sign "+") + +(template [<struct> <codec> <error>] + [(implementation: #export <struct> + (Codec Text Int) + + (def: (encode value) + (if (..< +0 value) + (|> value inc ..negate .nat inc (\ <codec> encode) ("lux text concat" ..-sign)) + (|> value .nat (\ <codec> encode) ("lux text concat" ..+sign)))) + + (def: (decode repr) + (let [input_size ("lux text size" repr)] + (if (//nat.> 1 input_size) + (case ("lux text clip" 0 1 repr) + (^ (static ..+sign)) + (|> repr + ("lux text clip" 1 (dec input_size)) + (\ <codec> decode) + (\ try.functor map .int)) + + (^ (static ..-sign)) + (|> repr + ("lux text clip" 1 (dec input_size)) + (\ <codec> decode) + (\ try.functor map (|>> dec .int ..negate dec))) + + _ + (#try.Failure <error>)) + (#try.Failure <error>)))))] + + [binary //nat.binary "Invalid binary syntax for Int: "] + [octal //nat.octal "Invalid octal syntax for Int: "] + [decimal //nat.decimal "Invalid syntax for Int: "] + [hex //nat.hex "Invalid hexadecimal syntax for Int: "] + ) + +(implementation: #export hash + (Hash Int) + + (def: &equivalence ..equivalence) + (def: hash .nat)) + +(def: #export (right_shift parameter subject) + {#.doc "Signed/arithmetic bitwise right-shift."} + (-> Nat Int Int) + (//i64.or (//i64.and //i64.sign subject) + (//i64.right_shift parameter subject))) diff --git a/stdlib/source/library/lux/math/number/nat.lux b/stdlib/source/library/lux/math/number/nat.lux new file mode 100644 index 000000000..52e252c84 --- /dev/null +++ b/stdlib/source/library/lux/math/number/nat.lux @@ -0,0 +1,380 @@ +(.module: + [library + [lux #* + [abstract + [hash (#+ Hash)] + [enum (#+ Enum)] + [interval (#+ Interval)] + [monoid (#+ Monoid)] + [equivalence (#+ Equivalence)] + [codec (#+ Codec)] + ["." order (#+ Order)]] + [control + ["." function] + ["." try (#+ Try)]] + [data + ["." maybe]]]]) + +(template [<extension> <output> <name> <documentation>] + [(def: #export (<name> parameter subject) + {#.doc <documentation>} + (-> Nat Nat <output>) + (<extension> parameter subject))] + + ["lux i64 =" Bit = "Nat(ural) equivalence."] + ["lux i64 +" Nat + "Nat(ural) addition."] + ["lux i64 -" Nat - "Nat(ural) substraction."] + ) + +(def: high + (-> (I64 Any) I64) + (|>> ("lux i64 right-shift" 32))) + +(def: low + (-> (I64 Any) I64) + (let [mask (|> 1 ("lux i64 left-shift" 32) ("lux i64 -" 1))] + (|>> ("lux i64 and" mask)))) + +(def: #export (< reference sample) + {#.doc "Nat(ural) less-than."} + (-> Nat Nat Bit) + (let [referenceH (..high reference) + sampleH (..high sample)] + (if ("lux i64 <" referenceH sampleH) + #1 + (if ("lux i64 =" referenceH sampleH) + ("lux i64 <" + (..low reference) + (..low sample)) + #0)))) + +(def: #export (<= reference sample) + {#.doc "Nat(ural) less-than or equal."} + (-> Nat Nat Bit) + (if (..< reference sample) + #1 + ("lux i64 =" reference sample))) + +(def: #export (> reference sample) + {#.doc "Nat(ural) greater-than."} + (-> Nat Nat Bit) + (..< sample reference)) + +(def: #export (>= reference sample) + {#.doc "Nat(ural) greater-than or equal."} + (-> Nat Nat Bit) + (if (..< sample reference) + #1 + ("lux i64 =" reference sample))) + +(template [<name> <test> <doc>] + [(def: #export (<name> left right) + {#.doc <doc>} + (-> Nat Nat Nat) + (if (<test> right left) + left + right))] + + [min ..< "Nat(ural) minimum."] + [max ..> "Nat(ural) maximum."] + ) + +(def: #export (* parameter subject) + {#.doc "Nat(ural) multiplication."} + (-> Nat Nat Nat) + (:as Nat + ("lux i64 *" + (:as Int parameter) + (:as Int subject)))) + +(def: #export (/ parameter subject) + {#.doc "Nat(ural) division."} + (-> Nat Nat Nat) + (if ("lux i64 <" +0 (:as Int parameter)) + (if (..< parameter subject) + 0 + 1) + (let [quotient (|> subject + ("lux i64 right-shift" 1) + ("lux i64 /" (:as Int parameter)) + ("lux i64 left-shift" 1)) + flat ("lux i64 *" + (:as Int parameter) + (:as Int quotient)) + remainder ("lux i64 -" flat subject)] + (if (..< parameter remainder) + quotient + ("lux i64 +" 1 quotient))))) + +(def: #export (/% parameter subject) + {#.doc "Nat(ural) [division remainder]."} + (-> Nat Nat [Nat Nat]) + (let [quotient (../ parameter subject) + flat ("lux i64 *" + (:as Int parameter) + (:as Int quotient))] + [quotient ("lux i64 -" flat subject)])) + +(def: #export (% parameter subject) + {#.doc "Nat(ural) remainder."} + (-> Nat Nat Nat) + (let [flat ("lux i64 *" + (:as Int parameter) + (:as Int (../ parameter subject)))] + ("lux i64 -" flat subject))) + +(def: #export (gcd a b) + {#.doc "Greatest Common Divisor."} + (-> Nat Nat Nat) + (case b + 0 a + _ (gcd b (..% b a)))) + +(def: #export (co-prime? a b) + (-> Nat Nat Bit) + (..= 1 (..gcd a b))) + +(def: #export (lcm a b) + {#.doc "Least Common Multiple."} + (-> Nat Nat Nat) + (case [a b] + (^or [_ 0] [0 _]) + 0 + + _ + (|> a (../ (..gcd a b)) (..* b)))) + +(def: #export even? + (-> Nat Bit) + (|>> (..% 2) ("lux i64 =" 0))) + +(def: #export odd? + (-> Nat Bit) + (|>> ..even? not)) + +(def: #export frac + (-> Nat Frac) + (|>> .int "lux i64 f64")) + +(implementation: #export equivalence + (Equivalence Nat) + + (def: = ..=)) + +(implementation: #export order + (Order Nat) + + (def: &equivalence ..equivalence) + (def: < ..<)) + +(implementation: #export enum + (Enum Nat) + + (def: &order ..order) + (def: succ inc) + (def: pred dec)) + +(implementation: #export interval + (Interval Nat) + + (def: &enum ..enum) + (def: top (dec 0)) + (def: bottom 0)) + +(template [<name> <compose> <identity>] + [(implementation: #export <name> + (Monoid Nat) + + (def: identity <identity>) + (def: compose <compose>))] + + [addition ..+ 0] + [multiplication ..* 1] + [minimum ..min (\ ..interval top)] + [maximum ..max (\ ..interval bottom)] + ) + +(def: (binary-character value) + (-> Nat Text) + (case value + 0 "0" + 1 "1" + _ (undefined))) + +(def: (binary-value digit) + (-> Nat (Maybe Nat)) + (case digit + (^ (char "0")) (#.Some 0) + (^ (char "1")) (#.Some 1) + _ #.None)) + +(def: (octal-character value) + (-> Nat Text) + (case value + 0 "0" + 1 "1" + 2 "2" + 3 "3" + 4 "4" + 5 "5" + 6 "6" + 7 "7" + _ (undefined))) + +(def: (octal-value digit) + (-> Nat (Maybe Nat)) + (case digit + (^ (char "0")) (#.Some 0) + (^ (char "1")) (#.Some 1) + (^ (char "2")) (#.Some 2) + (^ (char "3")) (#.Some 3) + (^ (char "4")) (#.Some 4) + (^ (char "5")) (#.Some 5) + (^ (char "6")) (#.Some 6) + (^ (char "7")) (#.Some 7) + _ #.None)) + +(def: (decimal-character value) + (-> Nat Text) + (case value + 0 "0" + 1 "1" + 2 "2" + 3 "3" + 4 "4" + 5 "5" + 6 "6" + 7 "7" + 8 "8" + 9 "9" + _ (undefined))) + +(def: (decimal-value digit) + (-> Nat (Maybe Nat)) + (case digit + (^ (char "0")) (#.Some 0) + (^ (char "1")) (#.Some 1) + (^ (char "2")) (#.Some 2) + (^ (char "3")) (#.Some 3) + (^ (char "4")) (#.Some 4) + (^ (char "5")) (#.Some 5) + (^ (char "6")) (#.Some 6) + (^ (char "7")) (#.Some 7) + (^ (char "8")) (#.Some 8) + (^ (char "9")) (#.Some 9) + _ #.None)) + +(def: (hexadecimal-character value) + (-> Nat Text) + (case value + 0 "0" + 1 "1" + 2 "2" + 3 "3" + 4 "4" + 5 "5" + 6 "6" + 7 "7" + 8 "8" + 9 "9" + 10 "A" + 11 "B" + 12 "C" + 13 "D" + 14 "E" + 15 "F" + _ (undefined))) + +(def: (hexadecimal-value digit) + (-> Nat (Maybe Nat)) + (case digit + (^template [<character> <number>] + [(^ (char <character>)) (#.Some <number>)]) + (["0" 0] ["1" 1] ["2" 2] ["3" 3] ["4" 4] + ["5" 5] ["6" 6] ["7" 7] ["8" 8] ["9" 9]) + + (^template [<lower> <upper> <number>] + [(^or (^ (char <lower>)) (^ (char <upper>))) (#.Some <number>)]) + (["a" "A" 10] ["b" "B" 11] ["c" "C" 12] + ["d" "D" 13] ["e" "E" 14] ["f" "F" 15]) + _ #.None)) + +(template [<shift> <struct> <to-character> <to-value> <error>] + [(implementation: #export <struct> + (Codec Text Nat) + + (def: encode + (let [mask (|> 1 ("lux i64 left-shift" <shift>) dec)] + (function (_ value) + (loop [input value + output ""] + (let [output' ("lux text concat" + (<to-character> ("lux i64 and" mask input)) + output)] + (case (: Nat ("lux i64 right-shift" <shift> input)) + 0 + output' + + input' + (recur input' output'))))))) + + (def: (decode repr) + (let [input-size ("lux text size" repr)] + (if (..> 0 input-size) + (loop [idx 0 + output 0] + (if (..< input-size idx) + (case (<to-value> ("lux text char" idx repr)) + (#.Some digit-value) + (recur (inc idx) + (|> output + ("lux i64 left-shift" <shift>) + ("lux i64 or" digit-value))) + + _ + (#try.Failure ("lux text concat" <error> repr))) + (#try.Success output))) + (#try.Failure ("lux text concat" <error> repr))))))] + + [1 binary binary-character binary-value "Invalid binary syntax for Nat: "] + [3 octal octal-character octal-value "Invalid octal syntax for Nat: "] + [4 hex hexadecimal-character hexadecimal-value "Invalid hexadecimal syntax for Nat: "] + ) + +(implementation: #export decimal + (Codec Text Nat) + + (def: (encode value) + (loop [input value + output ""] + (let [digit (decimal-character (..% 10 input)) + output' ("lux text concat" digit output)] + (case (../ 10 input) + 0 + output' + + input' + (recur input' output'))))) + + (def: (decode repr) + (let [input-size ("lux text size" repr)] + (with_expansions [<failure> (#try.Failure ("lux text concat" "Invalid decimal syntax for Nat: " repr))] + (if (..> 0 input-size) + (loop [idx 0 + output 0] + (if (..< input-size idx) + (case (decimal-value ("lux text char" idx repr)) + #.None + <failure> + + (#.Some digit-value) + (recur (inc idx) + (|> output (..* 10) (..+ digit-value)))) + (#try.Success output))) + <failure>))))) + +(implementation: #export hash + (Hash Nat) + + (def: &equivalence ..equivalence) + (def: hash function.identity)) diff --git a/stdlib/source/library/lux/math/number/ratio.lux b/stdlib/source/library/lux/math/number/ratio.lux new file mode 100644 index 000000000..ecfdf30a0 --- /dev/null +++ b/stdlib/source/library/lux/math/number/ratio.lux @@ -0,0 +1,162 @@ +(.module: + {#.doc "Rational numbers."} + [library + [lux (#- nat) + [abstract + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [monoid (#+ Monoid)] + [codec (#+ Codec)] + [monad (#+ do)]] + [control + ["." function] + ["." try] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text ("#\." monoid)]] + [macro + [syntax (#+ syntax:)] + ["." code]]]] + [// + ["n" nat ("#\." decimal)]]) + +(type: #export Ratio + {#numerator Nat + #denominator Nat}) + +(def: #export (nat value) + (-> Ratio (Maybe Nat)) + (case (get@ #denominator value) + 1 (#.Some (get@ #numerator value)) + _ #.None)) + +(def: (normalize (^slots [#numerator #denominator])) + (-> Ratio Ratio) + (let [common (n.gcd numerator denominator)] + {#numerator (n./ common numerator) + #denominator (n./ common denominator)})) + +(syntax: #export (ratio numerator {?denominator (<>.maybe <code>.any)}) + {#.doc (doc "Rational literals." + (ratio numerator denominator) + "The denominator can be omitted if it's 1." + (ratio numerator))} + (wrap (list (` ((~! ..normalize) {#..numerator (~ numerator) + #..denominator (~ (maybe.default (' 1) + ?denominator))}))))) + +(def: #export (= parameter subject) + (-> Ratio Ratio Bit) + (and (n.= (get@ #numerator parameter) + (get@ #numerator subject)) + (n.= (get@ #denominator parameter) + (get@ #denominator subject)))) + +(implementation: #export equivalence + (Equivalence Ratio) + + (def: = ..=)) + +(def: (equalize parameter subject) + (-> Ratio Ratio [Nat Nat]) + [(n.* (get@ #denominator subject) + (get@ #numerator parameter)) + (n.* (get@ #denominator parameter) + (get@ #numerator subject))]) + +(def: #export (< parameter subject) + (-> Ratio Ratio Bit) + (let [[parameter' subject'] (..equalize parameter subject)] + (n.< parameter' subject'))) + +(def: #export (<= parameter subject) + (-> Ratio Ratio Bit) + (or (< parameter subject) + (= parameter subject))) + +(def: #export (> parameter subject) + (-> Ratio Ratio Bit) + (..< subject parameter)) + +(def: #export (>= parameter subject) + (-> Ratio Ratio Bit) + (or (> parameter subject) + (= parameter subject))) + +(implementation: #export order + (Order Ratio) + + (def: &equivalence ..equivalence) + (def: < ..<)) + +(def: #export (+ parameter subject) + (-> Ratio Ratio Ratio) + (let [[parameter' subject'] (..equalize parameter subject)] + (normalize [(n.+ parameter' subject') + (n.* (get@ #denominator parameter) + (get@ #denominator subject))]))) + +(def: #export (- parameter subject) + (-> Ratio Ratio Ratio) + (let [[parameter' subject'] (..equalize parameter subject)] + (normalize [(n.- parameter' subject') + (n.* (get@ #denominator parameter) + (get@ #denominator subject))]))) + +(def: #export (* parameter subject) + (-> Ratio Ratio Ratio) + (normalize [(n.* (get@ #numerator parameter) + (get@ #numerator subject)) + (n.* (get@ #denominator parameter) + (get@ #denominator subject))])) + +(def: #export (/ parameter subject) + (-> Ratio Ratio Ratio) + (let [[parameter' subject'] (..equalize parameter subject)] + (normalize [subject' parameter']))) + +(def: #export (% parameter subject) + (-> Ratio Ratio Ratio) + (let [[parameter' subject'] (..equalize parameter subject) + quot (n./ parameter' subject')] + (..- (update@ #numerator (n.* quot) parameter) + subject))) + +(def: #export (reciprocal (^slots [#numerator #denominator])) + (-> Ratio Ratio) + {#numerator denominator + #denominator numerator}) + +(def: separator ":") + +(implementation: #export codec + (Codec Text Ratio) + + (def: (encode (^slots [#numerator #denominator])) + ($_ text\compose (n\encode numerator) ..separator (n\encode denominator))) + + (def: (decode input) + (case (text.split_with ..separator input) + (#.Some [num denom]) + (do try.monad + [numerator (n\decode num) + denominator (n\decode denom)] + (wrap (normalize {#numerator numerator + #denominator denominator}))) + + #.None + (#.Left (text\compose "Invalid syntax for ratio: " input))))) + +(template [<identity> <compose> <name>] + [(implementation: #export <name> + (Monoid Ratio) + + (def: identity (..ratio <identity>)) + (def: compose <compose>))] + + [0 ..+ addition] + [1 ..* multiplication] + ) diff --git a/stdlib/source/library/lux/math/number/rev.lux b/stdlib/source/library/lux/math/number/rev.lux new file mode 100644 index 000000000..431f44ed1 --- /dev/null +++ b/stdlib/source/library/lux/math/number/rev.lux @@ -0,0 +1,463 @@ +(.module: + [library + [lux #* + [abstract + [hash (#+ Hash)] + [enum (#+ Enum)] + [interval (#+ Interval)] + [monoid (#+ Monoid)] + [equivalence (#+ Equivalence)] + [codec (#+ Codec)] + [order (#+ Order)]] + [control + ["." try]] + [data + ["." maybe] + [collection + ["." array (#+ Array)]]]]] + ["." // #_ + ["#." i64] + ["#." nat] + ["#." int]]) + +(template [<power> <name>] + [(def: #export <name> + Rev + (.rev (//i64.left_shift (//nat.- <power> //i64.width) 1)))] + + [01 /2] + [02 /4] + [03 /8] + [04 /16] + [05 /32] + [06 /64] + [07 /128] + [08 /256] + [09 /512] + [10 /1024] + [11 /2048] + [12 /4096] + ) + +(def: #export (= reference sample) + {#.doc "Rev(olution) equivalence."} + (-> Rev Rev Bit) + ("lux i64 =" reference sample)) + +(def: #export (< reference sample) + {#.doc "Rev(olution) less-than."} + (-> Rev Rev Bit) + (//nat.< (.nat reference) (.nat sample))) + +(def: #export (<= reference sample) + {#.doc "Rev(olution) less-than or equal."} + (-> Rev Rev Bit) + (if (//nat.< (.nat reference) (.nat sample)) + true + ("lux i64 =" reference sample))) + +(def: #export (> reference sample) + {#.doc "Rev(olution) greater-than."} + (-> Rev Rev Bit) + (..< sample reference)) + +(def: #export (>= reference sample) + {#.doc "Rev(olution) greater-than or equal."} + (-> Rev Rev Bit) + (if (..< sample reference) + true + ("lux i64 =" reference sample))) + +(template [<name> <test> <doc>] + [(def: #export (<name> left right) + {#.doc <doc>} + (-> Rev Rev Rev) + (if (<test> right left) + left + right))] + + [min ..< "Rev(olution) minimum."] + [max ..> "Rev(olution) maximum."] + ) + +(template [<name> <op> <doc>] + [(def: #export (<name> param subject) + {#.doc <doc>} + (-> Rev Rev Rev) + (<op> param subject))] + + [+ "lux i64 +" "Rev(olution) addition."] + [- "lux i64 -" "Rev(olution) substraction."] + ) + +(def: high + (-> (I64 Any) I64) + (|>> ("lux i64 right-shift" 32))) + +(def: low + (-> (I64 Any) I64) + (let [mask (|> 1 ("lux i64 left-shift" 32) ("lux i64 -" 1))] + (|>> ("lux i64 and" mask)))) + +(def: #export (* param subject) + {#.doc "Rev(olution) multiplication."} + (-> Rev Rev Rev) + (let [subjectH (..high subject) + subjectL (..low subject) + paramH (..high param) + paramL (..low param) + bottom (|> subjectL + ("lux i64 *" paramL) + ("lux i64 right-shift" 32)) + middle ("lux i64 +" + ("lux i64 *" paramL subjectH) + ("lux i64 *" paramH subjectL)) + top ("lux i64 *" subjectH paramH)] + (|> bottom + ("lux i64 +" middle) + ..high + ("lux i64 +" top)))) + +(def: even_one (//i64.rotate_right 1 1)) +(def: odd_one (dec 0)) + +(def: (even_reciprocal numerator) + (-> Nat Nat) + (//nat./ (//i64.right_shift 1 numerator) + ..even_one)) + +(def: (odd_reciprocal numerator) + (-> Nat Nat) + (//nat./ numerator ..odd_one)) + +(with_expansions [<least_significant_bit> 1] + (def: #export (reciprocal numerator) + {#.doc "Rev(olution) reciprocal of a Nat(ural)."} + (-> Nat Rev) + (.rev (case (: Nat ("lux i64 and" <least_significant_bit> numerator)) + 0 (..even_reciprocal numerator) + _ (..odd_reciprocal numerator)))) + + (def: #export (/ param subject) + {#.doc "Rev(olution) division."} + (-> Rev Rev Rev) + (if ("lux i64 =" +0 param) + (error! "Cannot divide Rev by zero!") + (let [reciprocal (case (: Nat ("lux i64 and" <least_significant_bit> param)) + 0 (..even_reciprocal (.nat param)) + _ (..odd_reciprocal (.nat param)))] + (.rev (//nat.* reciprocal (.nat subject))))))) + +(template [<operator> <name> <output> <output_type> <documentation>] + [(def: #export (<name> param subject) + {#.doc <documentation>} + (-> Rev Rev <output_type>) + (<output> (<operator> (.nat param) (.nat subject))))] + + [//nat.% % .rev Rev "Rev(olution) remainder."] + [//nat./ ratio |> Nat "Ratio between two rev(olution)s."] + ) + +(template [<operator> <name>] + [(def: #export (<name> scale subject) + (-> Nat Rev Rev) + (.rev (<operator> (.nat scale) (.nat subject))))] + + [//nat.* up] + [//nat./ down] + ) + +(def: #export (/% param subject) + (-> Rev Rev [Rev Rev]) + [(../ param subject) + (..% param subject)]) + +(def: mantissa + (-> (I64 Any) Frac) + (|>> ("lux i64 right-shift" 11) + "lux i64 f64")) + +(def: frac_denominator + (..mantissa -1)) + +(def: #export frac + (-> Rev Frac) + (|>> ..mantissa ("lux f64 /" ..frac_denominator))) + +(implementation: #export equivalence + (Equivalence Rev) + + (def: = ..=)) + +(implementation: #export hash + (Hash Rev) + + (def: &equivalence ..equivalence) + (def: hash .nat)) + +(implementation: #export order + (Order Rev) + + (def: &equivalence ..equivalence) + (def: < ..<)) + +(implementation: #export enum + (Enum Rev) + + (def: &order ..order) + (def: succ inc) + (def: pred dec)) + +(implementation: #export interval + (Interval Rev) + + (def: &enum ..enum) + (def: top (.rev -1)) + (def: bottom (.rev 0))) + +(template [<name> <compose> <identity>] + [(implementation: #export <name> + (Monoid Rev) + + (def: identity (\ interval <identity>)) + (def: compose <compose>))] + + [addition ..+ bottom] + [maximum ..max bottom] + [minimum ..min top] + ) + +(def: (de_prefix input) + (-> Text Text) + ("lux text clip" 1 (dec ("lux text size" input)) input)) + +(template [<struct> <codec> <char_bit_size> <error>] + [(with_expansions [<error_output> (as_is (#try.Failure ("lux text concat" <error> repr)))] + (implementation: #export <struct> + (Codec Text Rev) + + (def: (encode value) + (let [raw_output (\ <codec> encode (.nat value)) + max_num_chars (//nat.+ (//nat./ <char_bit_size> //i64.width) + (case (//nat.% <char_bit_size> //i64.width) + 0 0 + _ 1)) + raw_size ("lux text size" raw_output) + zero_padding (: Text + (loop [zeroes_left (: Nat (//nat.- raw_size max_num_chars)) + output (: Text "")] + (if (//nat.= 0 zeroes_left) + output + (recur (dec zeroes_left) + ("lux text concat" "0" output)))))] + (|> raw_output + ("lux text concat" zero_padding) + ("lux text concat" ".")))) + + (def: (decode repr) + (let [repr_size ("lux text size" repr)] + (if (//nat.> 1 repr_size) + (case ("lux text char" 0 repr) + (^ (char ".")) + (case (\ <codec> decode (de_prefix repr)) + (#try.Success output) + (#try.Success (.rev output)) + + _ + <error_output>) + + _ + <error_output>) + <error_output>)))))] + + [binary //nat.binary 1 "Invalid binary syntax: "] + [octal //nat.octal 3 "Invalid octal syntax: "] + [hex //nat.hex 4 "Invalid hexadecimal syntax: "] + ) + +## The following code allows one to encode/decode Rev numbers as text. +## This is not a simple algorithm, and it requires subverting the Rev +## abstraction a bit. +## It takes into account the fact that Rev numbers are represented by +## Lux as 64-bit integers. +## A valid way to model them is as Lux's Nat type. +## This is a somewhat hackish way to do things, but it allows one to +## write the encoding/decoding algorithm once, in pure Lux, rather +## than having to implement it on the compiler for every platform +## targeted by Lux. +(type: Digits (Array Nat)) + +(def: (digits::new _) + (-> Any Digits) + (array.new //i64.width)) + +(def: (digits::get idx digits) + (-> Nat Digits Nat) + (|> digits (array.read idx) (maybe.default 0))) + +(def: digits::put + (-> Nat Nat Digits Digits) + array.write!) + +(def: (prepend left right) + (-> Text Text Text) + ("lux text concat" left right)) + +(def: (digits::times_5! idx output) + (-> Nat Digits Digits) + (loop [idx idx + carry 0 + output output] + (if (//int.>= +0 (.int idx)) + (let [raw (|> (digits::get idx output) + (//nat.* 5) + (//nat.+ carry))] + (recur (dec idx) + (//nat./ 10 raw) + (digits::put idx (//nat.% 10 raw) output))) + output))) + +(def: (digits::power power) + (-> Nat Digits) + (loop [times power + output (|> (digits::new []) + (digits::put power 1))] + (if (//int.>= +0 (.int times)) + (recur (dec times) + (digits::times_5! power output)) + output))) + +(def: (digits::format digits) + (-> Digits Text) + (loop [idx (dec //i64.width) + all_zeroes? true + output ""] + (if (//int.>= +0 (.int idx)) + (let [digit (digits::get idx digits)] + (if (and (//nat.= 0 digit) + all_zeroes?) + (recur (dec idx) true output) + (recur (dec idx) + false + ("lux text concat" + (\ //nat.decimal encode digit) + output)))) + (if all_zeroes? + "0" + output)))) + +(def: (digits::+ param subject) + (-> Digits Digits Digits) + (loop [idx (dec //i64.width) + carry 0 + output (digits::new [])] + (if (//int.>= +0 (.int idx)) + (let [raw ($_ //nat.+ + carry + (digits::get idx param) + (digits::get idx subject))] + (recur (dec idx) + (//nat./ 10 raw) + (digits::put idx (//nat.% 10 raw) output))) + output))) + +(def: (text_to_digits input) + (-> Text (Maybe Digits)) + (let [length ("lux text size" input)] + (if (//nat.<= //i64.width length) + (loop [idx 0 + output (digits::new [])] + (if (//nat.< length idx) + (case ("lux text index" 0 ("lux text clip" idx 1 input) "0123456789") + #.None + #.None + + (#.Some digit) + (recur (inc idx) + (digits::put idx digit output))) + (#.Some output))) + #.None))) + +(def: (digits::< param subject) + (-> Digits Digits Bit) + (loop [idx 0] + (and (//nat.< //i64.width idx) + (let [pd (digits::get idx param) + sd (digits::get idx subject)] + (if (//nat.= pd sd) + (recur (inc idx)) + (//nat.< pd sd)))))) + +(def: (digits::-!' idx param subject) + (-> Nat Nat Digits Digits) + (let [sd (digits::get idx subject)] + (if (//nat.>= param sd) + (digits::put idx (//nat.- param sd) subject) + (let [diff (|> sd + (//nat.+ 10) + (//nat.- param))] + (|> subject + (digits::put idx diff) + (digits::-!' (dec idx) 1)))))) + +(def: (digits::-! param subject) + (-> Digits Digits Digits) + (loop [idx (dec //i64.width) + output subject] + (if (//int.>= +0 (.int idx)) + (recur (dec idx) + (digits::-!' idx (digits::get idx param) output)) + output))) + +(implementation: #export decimal + (Codec Text Rev) + + (def: (encode input) + (case (.nat input) + 0 + ".0" + + input + (let [last_idx (dec //i64.width)] + (loop [idx last_idx + digits (digits::new [])] + (if (//int.>= +0 (.int idx)) + (if (//i64.set? idx input) + (let [digits' (digits::+ (digits::power (//nat.- idx last_idx)) + digits)] + (recur (dec idx) + digits')) + (recur (dec idx) + digits)) + ("lux text concat" "." (digits::format digits)) + ))))) + + (def: (decode input) + (let [dotted? (case ("lux text index" 0 "." input) + (#.Some 0) + true + + _ + false) + within_limits? (//nat.<= (inc //i64.width) + ("lux text size" input))] + (if (and dotted? within_limits?) + (case (text_to_digits (de_prefix input)) + (#.Some digits) + (loop [digits digits + idx 0 + output 0] + (if (//nat.< //i64.width idx) + (let [power (digits::power idx)] + (if (digits::< power digits) + ## Skip power + (recur digits (inc idx) output) + (recur (digits::-! power digits) + (inc idx) + (//i64.set (//nat.- idx (dec //i64.width)) output)))) + (#try.Success (.rev output)))) + + #.None + (#try.Failure ("lux text concat" "Wrong syntax for Rev: " input))) + (#try.Failure ("lux text concat" "Wrong syntax for Rev: " input)))) + )) diff --git a/stdlib/source/library/lux/math/random.lux b/stdlib/source/library/lux/math/random.lux new file mode 100644 index 000000000..8b555e21d --- /dev/null +++ b/stdlib/source/library/lux/math/random.lux @@ -0,0 +1,400 @@ +(.module: {#.doc "Pseudo-random number generation (PRNG) algorithms."} + [library + [lux (#- or and list i64 nat int rev char) + [abstract + [hash (#+ Hash)] + [functor (#+ Functor)] + [apply (#+ Apply)] + ["." monad (#+ Monad do)]] + [data + ["." text (#+ Char) ("#\." monoid) + ["." unicode #_ + ["#" set]]] + [collection + ["." list ("#\." fold)] + ["." array (#+ Array)] + ["." dictionary (#+ Dictionary)] + ["." queue (#+ Queue)] + ["." set (#+ Set)] + ["." stack (#+ Stack)] + ["." row (#+ Row)] + [tree + ["." finger (#+ Tree)]]]] + [math + [number (#+ hex) + ["n" nat] + ["i" int] + ["f" frac] + ["r" ratio] + ["c" complex] + ["." i64]]] + ["." time (#+ Time) + ["." instant (#+ Instant)] + ["." date (#+ Date)] + ["." duration (#+ Duration)] + ["." month (#+ Month)] + ["." day (#+ Day)]] + [type + [refinement (#+ Refiner Refined)]]]]) + +(type: #export #rec PRNG + {#.doc "An abstract way to represent any PRNG."} + (-> Any [PRNG I64])) + +(type: #export (Random a) + {#.doc "A producer of random values based on a PRNG."} + (-> PRNG [PRNG a])) + +(implementation: #export functor + (Functor Random) + + (def: (map f fa) + (function (_ state) + (let [[state' a] (fa state)] + [state' (f a)])))) + +(implementation: #export apply + (Apply Random) + + (def: &functor ..functor) + + (def: (apply ff fa) + (function (_ state) + (let [[state' f] (ff state) + [state'' a] (fa state')] + [state'' (f a)])))) + +(implementation: #export monad + (Monad Random) + + (def: &functor ..functor) + + (def: (wrap a) + (function (_ state) + [state a])) + + (def: (join ffa) + (function (_ state) + (let [[state' fa] (ffa state)] + (fa state'))))) + +(def: #export (filter pred gen) + {#.doc "Retries the generator until the output satisfies a predicate."} + (All [a] (-> (-> a Bit) (Random a) (Random a))) + (do ..monad + [sample gen] + (if (pred sample) + (wrap sample) + (filter pred gen)))) + +(def: #export (one check random) + (All [a b] + (-> (-> a (Maybe b)) (Random a) (Random b))) + (do ..monad + [sample random] + (case (check sample) + (#.Some output) + (wrap output) + + #.None + (one check random)))) + +(def: #export (refine refiner gen) + {#.doc "Retries the generator until the output can be refined."} + (All [t r] (-> (Refiner t r) (Random t) (Random (Refined t r)))) + (do ..monad + [sample gen] + (case (refiner sample) + (#.Some refined) + (wrap refined) + + #.None + (refine refiner gen)))) + +(def: #export bit + (Random Bit) + (function (_ prng) + (let [[prng output] (prng [])] + [prng (|> output (i64.and 1) (n.= 1))]))) + +(def: #export i64 + (Random I64) + (function (_ prng) + (let [[prng left] (prng []) + [prng right] (prng [])] + [prng (|> left + (i64.left_shift 32) + ("lux i64 +" right))]))) + +(template [<name> <type> <cast>] + [(def: #export <name> + (Random <type>) + (\ ..monad map <cast> ..i64))] + + [nat Nat .nat] + [int Int .int] + [rev Rev .rev] + ) + +(def: #export frac + (Random Frac) + (\ ..monad map (|>> .i64 f.from_bits) ..nat)) + +(def: #export safe_frac + (Random Frac) + (let [mantissa_range (.int (i64.left_shift 53 1)) + mantissa_max (i.frac (dec mantissa_range))] + (\ ..monad map + (|>> (i.% mantissa_range) + i.frac + (f./ mantissa_max)) + ..int))) + +(def: #export (char set) + (-> unicode.Set (Random Char)) + (let [[start end] (unicode.range set) + size (n.- start end) + in_range (: (-> Char Char) + (|>> (n.% size) (n.+ start)))] + (|> ..nat + (\ ..monad map in_range) + (..filter (unicode.member? set))))) + +(def: #export (text char_gen size) + (-> (Random Char) Nat (Random Text)) + (if (n.= 0 size) + (\ ..monad wrap "") + (do ..monad + [x char_gen + xs (text char_gen (dec size))] + (wrap (text\compose (text.from_code x) xs))))) + +(template [<name> <set>] + [(def: #export <name> + (-> Nat (Random Text)) + (..text (..char <set>)))] + + [unicode unicode.character] + [ascii unicode.ascii] + [ascii/alpha unicode.ascii/alpha] + [ascii/alpha_num unicode.ascii/alpha_num] + [ascii/numeric unicode.ascii/numeric] + [ascii/upper unicode.ascii/upper] + [ascii/lower unicode.ascii/lower] + ) + +(template [<name> <type> <ctor> <gen>] + [(def: #export <name> + (Random <type>) + (do ..monad + [left <gen> + right <gen>] + (wrap (<ctor> left right))))] + + [ratio r.Ratio r.ratio ..nat] + [complex c.Complex c.complex ..safe_frac] + ) + +(def: #export (and left right) + {#.doc "Sequencing combinator."} + (All [a b] (-> (Random a) (Random b) (Random [a b]))) + (do ..monad + [=left left + =right right] + (wrap [=left =right]))) + +(def: #export (or left right) + {#.doc "Heterogeneous alternative combinator."} + (All [a b] (-> (Random a) (Random b) (Random (| a b)))) + (do {! ..monad} + [? bit] + (if ? + (do ! + [=left left] + (wrap (0 #0 =left))) + (do ! + [=right right] + (wrap (0 #1 =right)))))) + +(def: #export (either left right) + {#.doc "Homogeneous alternative combinator."} + (All [a] (-> (Random a) (Random a) (Random a))) + (do ..monad + [? bit] + (if ? + left + right))) + +(def: #export (rec gen) + {#.doc "A combinator for producing recursive random generators."} + (All [a] (-> (-> (Random a) (Random a)) (Random a))) + (function (_ state) + (let [gen' (gen (rec gen))] + (gen' state)))) + +(def: #export (maybe value_gen) + (All [a] (-> (Random a) (Random (Maybe a)))) + (do {! ..monad} + [some? bit] + (if some? + (do ! + [value value_gen] + (wrap (#.Some value))) + (wrap #.None)))) + +(template [<name> <type> <zero> <plus>] + [(def: #export (<name> size value_gen) + (All [a] (-> Nat (Random a) (Random (<type> a)))) + (if (n.> 0 size) + (do ..monad + [x value_gen + xs (<name> (dec size) value_gen)] + (wrap (<plus> x xs))) + (\ ..monad wrap <zero>)))] + + [list List (.list) #.Cons] + [row Row row.empty row.add] + ) + +(template [<name> <type> <ctor>] + [(def: #export (<name> size value_gen) + (All [a] (-> Nat (Random a) (Random (<type> a)))) + (do ..monad + [values (list size value_gen)] + (wrap (|> values <ctor>))))] + + [array Array array.from_list] + [queue Queue queue.from_list] + [stack Stack (list\fold stack.push stack.empty)] + ) + +(def: #export (set Hash<a> size value_gen) + (All [a] (-> (Hash a) Nat (Random a) (Random (Set a)))) + (if (n.> 0 size) + (do {! ..monad} + [xs (set Hash<a> (dec size) value_gen)] + (loop [_ []] + (do ! + [x value_gen + #let [xs+ (set.add x xs)]] + (if (n.= size (set.size xs+)) + (wrap xs+) + (recur []))))) + (\ ..monad wrap (set.new Hash<a>)))) + +(def: #export (dictionary Hash<a> size key_gen value_gen) + (All [k v] (-> (Hash k) Nat (Random k) (Random v) (Random (Dictionary k v)))) + (if (n.> 0 size) + (do {! ..monad} + [kv (dictionary Hash<a> (dec size) key_gen value_gen)] + (loop [_ []] + (do ! + [k key_gen + v value_gen + #let [kv+ (dictionary.put k v kv)]] + (if (n.= size (dictionary.size kv+)) + (wrap kv+) + (recur []))))) + (\ ..monad wrap (dictionary.new Hash<a>)))) + +(def: #export instant + (Random Instant) + (\ ..monad map instant.from_millis ..int)) + +(def: #export date + (Random Date) + (\ ..monad map instant.date ..instant)) + +(def: #export time + (Random Time) + (\ ..monad map instant.time ..instant)) + +(def: #export duration + (Random Duration) + (\ ..monad map duration.from_millis ..int)) + +(def: #export month + (Random Month) + (let [(^open "\.") ..monad] + (..either (..either (..either (\wrap #month.January) + (..either (\wrap #month.February) + (\wrap #month.March))) + (..either (\wrap #month.April) + (..either (\wrap #month.May) + (\wrap #month.June)))) + (..either (..either (\wrap #month.July) + (..either (\wrap #month.August) + (\wrap #month.September))) + (..either (\wrap #month.October) + (..either (\wrap #month.November) + (\wrap #month.December))))))) + +(def: #export day + (Random Day) + (let [(^open "\.") ..monad] + (..either (..either (\wrap #day.Sunday) + (..either (\wrap #day.Monday) + (\wrap #day.Tuesday))) + (..either (..either (\wrap #day.Wednesday) + (\wrap #day.Thursday)) + (..either (\wrap #day.Friday) + (\wrap #day.Saturday)))))) + +(def: #export (run prng calc) + (All [a] (-> PRNG (Random a) [PRNG a])) + (calc prng)) + +(def: #export (prng update return) + (All [a] (-> (-> a a) (-> a I64) (-> a PRNG))) + (function (recur state) + (function (_ _) + [(recur (update state)) + (return state)]))) + +(def: #export (pcg32 [increase seed]) + {#.doc (doc "An implementation of the PCG32 algorithm." + "For more information, please see: http://www.pcg-random.org/")} + (-> [(I64 Any) (I64 Any)] PRNG) + (let [magic 6364136223846793005] + (function (_ _) + [(|> seed .nat (n.* magic) ("lux i64 +" increase) [increase] pcg32) + (let [rot (|> seed .i64 (i64.right_shift 59))] + (|> seed + (i64.right_shift 18) + (i64.xor seed) + (i64.right_shift 27) + (i64.rotate_right rot) + .i64))]))) + +(def: #export (xoroshiro_128+ [s0 s1]) + {#.doc (doc "An implementation of the Xoroshiro128+ algorithm." + "For more information, please see: http://xoroshiro.di.unimi.it/")} + (-> [(I64 Any) (I64 Any)] PRNG) + (function (_ _) + [(let [s01 (i64.xor s0 s1)] + (xoroshiro_128+ [(|> s0 + (i64.rotate_left 55) + (i64.xor s01) + (i64.xor (i64.left_shift 14 s01))) + (i64.rotate_left 36 s01)])) + ("lux i64 +" s0 s1)])) + +## https://en.wikipedia.org/wiki/Xorshift#Initialization +## http://xorshift.di.unimi.it/splitmix64.c +(def: #export split_mix_64 + {#.doc (doc "An implementation of the SplitMix64 algorithm.")} + (-> Nat PRNG) + (let [twist (: (-> Nat Nat Nat) + (function (_ shift value) + (i64.xor (i64.right_shift shift value) + value))) + mix n.*] + (..prng (n.+ (hex "9E,37,79,B9,7F,4A,7C,15")) + (|>> (twist 30) + (mix (hex "BF,58,47,6D,1C,E4,E5,B9")) + + (twist 27) + (mix (hex "94,D0,49,BB,13,31,11,EB")) + + (twist 31) + .i64)))) diff --git a/stdlib/source/library/lux/meta.lux b/stdlib/source/library/lux/meta.lux new file mode 100644 index 000000000..b86100325 --- /dev/null +++ b/stdlib/source/library/lux/meta.lux @@ -0,0 +1,568 @@ +(.module: {#.doc "Functions for extracting information from the state of the compiler."} + [library + [lux #* + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + ["." monad (#+ Monad do)]] + [control + ["." try (#+ Try)]] + [data + ["." product] + ["." maybe] + ["." text ("#\." monoid equivalence)] + ["." name ("#\." codec equivalence)] + [collection + ["." list ("#\." monoid monad)] + [dictionary + ["." plist]]]] + [macro + ["." code]] + [math + [number + ["n" nat] + ["i" int]]]]] + [/ + ["." location]]) + +## (type: (Meta a) +## (-> Lux (Try [Lux a]))) + +(implementation: #export functor + (Functor Meta) + + (def: (map f fa) + (function (_ compiler) + (case (fa compiler) + (#try.Failure msg) + (#try.Failure msg) + + (#try.Success [compiler' a]) + (#try.Success [compiler' (f a)]))))) + +(implementation: #export apply + (Apply Meta) + + (def: &functor ..functor) + + (def: (apply ff fa) + (function (_ compiler) + (case (ff compiler) + (#try.Success [compiler' f]) + (case (fa compiler') + (#try.Success [compiler'' a]) + (#try.Success [compiler'' (f a)]) + + (#try.Failure msg) + (#try.Failure msg)) + + (#try.Failure msg) + (#try.Failure msg))))) + +(implementation: #export monad + (Monad Meta) + + (def: &functor ..functor) + + (def: (wrap x) + (function (_ compiler) + (#try.Success [compiler x]))) + + (def: (join mma) + (function (_ compiler) + (case (mma compiler) + (#try.Failure msg) + (#try.Failure msg) + + (#try.Success [compiler' ma]) + (ma compiler'))))) + +(def: #export (run' compiler action) + (All [a] (-> Lux (Meta a) (Try [Lux a]))) + (action compiler)) + +(def: #export (run compiler action) + (All [a] (-> Lux (Meta a) (Try a))) + (case (action compiler) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [_ output]) + (#try.Success output))) + +(def: #export (either left right) + {#.doc "Pick whichever computation succeeds."} + (All [a] (-> (Meta a) (Meta a) (Meta a))) + (function (_ compiler) + (case (left compiler) + (#try.Failure error) + (right compiler) + + (#try.Success [compiler' output]) + (#try.Success [compiler' output])))) + +(def: #export (assert message test) + {#.doc "Fails with the given message if the test is #0."} + (-> Text Bit (Meta Any)) + (function (_ compiler) + (if test + (#try.Success [compiler []]) + (#try.Failure message)))) + +(def: #export (fail error) + {#.doc "Fails with the given error message."} + (All [a] + (-> Text (Meta a))) + (function (_ state) + (#try.Failure (location.with (get@ #.location state) error)))) + +(def: #export (find_module name) + (-> Text (Meta Module)) + (function (_ compiler) + (case (plist.get name (get@ #.modules compiler)) + (#.Some module) + (#try.Success [compiler module]) + + _ + (#try.Failure ($_ text\compose "Unknown module: " name))))) + +(def: #export current_module_name + (Meta Text) + (function (_ compiler) + (case (get@ #.current_module compiler) + (#.Some current_module) + (#try.Success [compiler current_module]) + + _ + (#try.Failure "No current module.")))) + +(def: #export current_module + (Meta Module) + (let [(^open "\.") ..monad] + (|> ..current_module_name + (\map ..find_module) + \join))) + +(def: (macro_type? type) + (-> Type Bit) + (`` (case type + (#.Named [(~~ (static .prelude_module)) "Macro"] (#.Primitive "#Macro" #.Nil)) + true + + _ + false))) + +(def: #export (normalize name) + {#.doc (doc "If given a name without a module prefix, gives it the current module's name as prefix." + "Otherwise, returns the name as-is.")} + (-> Name (Meta Name)) + (case name + ["" name] + (do ..monad + [module_name ..current_module_name] + (wrap [module_name name])) + + _ + (\ ..monad wrap name))) + +(def: (find_macro' modules this_module module name) + (-> (List [Text Module]) Text Text Text + (Maybe Macro)) + (do maybe.monad + [$module (plist.get module modules) + definition (: (Maybe Global) + (|> (: Module $module) + (get@ #.definitions) + (plist.get name)))] + (case definition + (#.Alias [r_module r_name]) + (find_macro' modules this_module r_module r_name) + + (#.Definition [exported? def_type def_anns def_value]) + (if (macro_type? def_type) + (#.Some (:as Macro def_value)) + #.None)))) + +(def: #export (find_macro full_name) + (-> Name (Meta (Maybe Macro))) + (do ..monad + [[module name] (normalize full_name)] + (: (Meta (Maybe Macro)) + (function (_ compiler) + (let [macro (case (..current_module_name compiler) + (#try.Failure error) + #.None + + (#try.Success [_ this_module]) + (find_macro' (get@ #.modules compiler) this_module module name))] + (#try.Success [compiler macro])))))) + +(def: #export count + (Meta Nat) + (function (_ compiler) + (#try.Success [(update@ #.seed inc compiler) + (get@ #.seed compiler)]))) + +(def: #export (module_exists? module) + (-> Text (Meta Bit)) + (function (_ compiler) + (#try.Success [compiler (case (plist.get module (get@ #.modules compiler)) + (#.Some _) + #1 + + #.None + #0)]))) + +(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_type_var idx bindings) + (-> Nat (List [Nat (Maybe Type)]) (Maybe Type)) + (case bindings + #.Nil + #.None + + (#.Cons [var bound] bindings') + (if (n.= idx var) + bound + (find_type_var idx bindings')))) + +(def: (clean_type type) + (-> Type (Meta Type)) + (case type + (#.Var var) + (function (_ compiler) + (case (|> compiler + (get@ [#.type_context #.var_bindings]) + (find_type_var var)) + (^or #.None (#.Some (#.Var _))) + (#try.Success [compiler type]) + + (#.Some type') + (#try.Success [compiler type']))) + + _ + (\ ..monad wrap type))) + +(def: #export (find_var_type name) + {#.doc "Looks-up the type of a local variable somewhere in the environment."} + (-> Text (Meta Type)) + (function (_ compiler) + (let [test (: (-> [Text [Type Any]] Bit) + (|>> product.left (text\= name)))] + (case (do maybe.monad + [scope (list.find (function (_ env) + (or (list.any? test (: (List [Text [Type Any]]) + (get@ [#.locals #.mappings] env))) + (list.any? test (: (List [Text [Type Any]]) + (get@ [#.captured #.mappings] env))))) + (get@ #.scopes compiler)) + [_ [type _]] (try_both (list.find test) + (: (List [Text [Type Any]]) + (get@ [#.locals #.mappings] scope)) + (: (List [Text [Type Any]]) + (get@ [#.captured #.mappings] scope)))] + (wrap type)) + (#.Some var_type) + ((clean_type var_type) compiler) + + #.None + (#try.Failure ($_ text\compose "Unknown variable: " name)))))) + +(def: #export (find_def name) + {#.doc "Looks-up a definition's whole data in the available modules (including the current one)."} + (-> Name (Meta Global)) + (do ..monad + [name (normalize name) + #let [[normal_module normal_short] name]] + (function (_ compiler) + (case (: (Maybe Global) + (do maybe.monad + [(^slots [#.definitions]) (|> compiler + (get@ #.modules) + (plist.get normal_module))] + (plist.get normal_short definitions))) + (#.Some definition) + (#try.Success [compiler definition]) + + _ + (let [current_module (|> compiler (get@ #.current_module) (maybe.default "???")) + separator ($_ text\compose text.new_line " ")] + (#try.Failure ($_ text\compose + "Unknown definition: " (name\encode name) text.new_line + " Current module: " current_module text.new_line + (case (plist.get current_module (get@ #.modules compiler)) + (#.Some this_module) + (let [candidates (|> compiler + (get@ #.modules) + (list\map (function (_ [module_name module]) + (|> module + (get@ #.definitions) + (list.all (function (_ [def_name global]) + (case global + (#.Definition [exported? _ _ _]) + (if (and exported? + (text\= normal_short def_name)) + (#.Some (name\encode [module_name def_name])) + #.None) + + (#.Alias _) + #.None)))))) + list.concat + (text.join_with separator)) + imports (|> this_module + (get@ #.imports) + (text.join_with separator)) + aliases (|> this_module + (get@ #.module_aliases) + (list\map (function (_ [alias real]) ($_ text\compose alias " => " real))) + (text.join_with separator))] + ($_ text\compose + " Candidates: " candidates text.new_line + " Imports: " imports text.new_line + " Aliases: " aliases text.new_line)) + + _ + "") + " All known modules: " (|> compiler (get@ #.modules) (list\map product.left) (text.join_with separator)) text.new_line))))))) + +(def: #export (find_export name) + {#.doc "Looks-up a definition's type in the available modules (including the current one)."} + (-> Name (Meta Definition)) + (do ..monad + [definition (..find_def name)] + (case definition + (#.Left de_aliased) + (fail ($_ text\compose + "Aliases are not considered exports: " + (name\encode name))) + + (#.Right definition) + (let [[exported? def_type def_data def_value] definition] + (if exported? + (wrap definition) + (fail ($_ text\compose "Definition is not an export: " (name\encode name)))))))) + +(def: #export (find_def_type name) + {#.doc "Looks-up a definition's type in the available modules (including the current one)."} + (-> Name (Meta Type)) + (do ..monad + [definition (find_def name)] + (case definition + (#.Left de_aliased) + (find_def_type de_aliased) + + (#.Right [exported? def_type def_data def_value]) + (clean_type def_type)))) + +(def: #export (find_type name) + {#.doc "Looks-up the type of either a local variable or a definition."} + (-> Name (Meta Type)) + (do ..monad + [#let [[_ _name] name]] + (case name + ["" _name] + (either (find_var_type _name) + (find_def_type name)) + + _ + (find_def_type name)))) + +(def: #export (find_type_def name) + {#.doc "Finds the value of a type definition (such as Int, Any or Lux)."} + (-> Name (Meta Type)) + (do ..monad + [definition (find_def name)] + (case definition + (#.Left de_aliased) + (find_type_def de_aliased) + + (#.Right [exported? def_type def_data def_value]) + (let [type_to_code (`` ("lux in-module" (~~ (static .prelude_module)) .type_to_code))] + (if (or (is? .Type def_type) + (\ code.equivalence = + (type_to_code .Type) + (type_to_code def_type))) + (wrap (:as Type def_value)) + (..fail ($_ text\compose "Definition is not a type: " (name\encode name)))))))) + +(def: #export (globals module) + {#.doc "The entire list of globals in a module (including the non-exported/private ones)."} + (-> Text (Meta (List [Text Global]))) + (function (_ compiler) + (case (plist.get module (get@ #.modules compiler)) + #.None + (#try.Failure ($_ text\compose "Unknown module: " module)) + + (#.Some module) + (#try.Success [compiler (get@ #.definitions module)])))) + +(def: #export (definitions module) + {#.doc "The entire list of definitions in a module (including the non-exported/private ones)."} + (-> Text (Meta (List [Text Definition]))) + (\ ..monad map + (list.all (function (_ [name global]) + (case global + (#.Left de_aliased) + #.None + + (#.Right definition) + (#.Some [name definition])))) + (..globals module))) + +(def: #export (exports module_name) + {#.doc "All the exported definitions in a module."} + (-> Text (Meta (List [Text Definition]))) + (do ..monad + [constants (..definitions module_name)] + (wrap (do list.monad + [[name [exported? def_type def_data def_value]] constants] + (if exported? + (wrap [name [exported? def_type def_data def_value]]) + (list)))))) + +(def: #export modules + {#.doc "All the available modules (including the current one)."} + (Meta (List [Text Module])) + (function (_ compiler) + (|> compiler + (get@ #.modules) + [compiler] + #try.Success))) + +(def: #export (tags_of type_name) + {#.doc "All the tags associated with a type definition."} + (-> Name (Meta (Maybe (List Name)))) + (do ..monad + [#let [[module name] type_name] + module (find_module module)] + (case (plist.get name (get@ #.types module)) + (#.Some [tags _]) + (wrap (#.Some tags)) + + _ + (wrap #.None)))) + +(def: #export location + {#.doc "The location of the current expression being analyzed."} + (Meta Location) + (function (_ compiler) + (#try.Success [compiler (get@ #.location compiler)]))) + +(def: #export expected_type + {#.doc "The expected type of the current expression being analyzed."} + (Meta Type) + (function (_ compiler) + (case (get@ #.expected compiler) + (#.Some type) + (#try.Success [compiler type]) + + #.None + (#try.Failure "Not expecting any type.")))) + +(def: #export (imported_modules module_name) + {#.doc "All the modules imported by a specified module."} + (-> Text (Meta (List Text))) + (do ..monad + [(^slots [#.imports]) (..find_module module_name)] + (wrap imports))) + +(def: #export (imported_by? import module) + (-> Text Text (Meta Bit)) + (do ..monad + [(^slots [#.imports]) (..find_module module)] + (wrap (list.any? (text\= import) imports)))) + +(def: #export (imported? import) + (-> Text (Meta Bit)) + (\ ..functor map + (|>> (get@ #.imports) (list.any? (text\= import))) + ..current_module)) + +(def: #export (resolve_tag tag) + {#.doc "Given a tag, finds out what is its index, its related tag-list and its associated type."} + (-> Name (Meta [Nat (List Name) Type])) + (do ..monad + [#let [[module name] tag] + =module (..find_module module) + this_module_name ..current_module_name + imported! (..imported? module)] + (case (plist.get name (get@ #.tags =module)) + (#.Some [idx tag_list exported? type]) + (if (or (text\= this_module_name module) + (and imported! exported?)) + (wrap [idx tag_list type]) + (..fail ($_ text\compose "Cannot access tag: " (name\encode tag) " from module " this_module_name))) + + _ + (..fail ($_ text\compose + "Unknown tag: " (name\encode tag) text.new_line + " Known tags: " (|> =module + (get@ #.tags) + (list\map (|>> product.left [module] name\encode (text.prefix text.new_line))) + (text.join_with "")) + ))))) + +(def: #export (tag_lists module) + {#.doc "All the tag-lists defined in a module, with their associated types."} + (-> Text (Meta (List [(List Name) Type]))) + (do ..monad + [=module (..find_module module) + this_module_name ..current_module_name] + (wrap (|> (get@ #.types =module) + (list.filter (function (_ [type_name [tag_list exported? type]]) + (or exported? + (text\= this_module_name module)))) + (list\map (function (_ [type_name [tag_list exported? type]]) + [tag_list type])))))) + +(def: #export locals + {#.doc "All the local variables currently in scope, separated in different scopes."} + (Meta (List (List [Text Type]))) + (function (_ compiler) + (case (list.inits (get@ #.scopes compiler)) + #.None + (#try.Failure "No local environment") + + (#.Some scopes) + (#try.Success [compiler + (list\map (|>> (get@ [#.locals #.mappings]) + (list\map (function (_ [name [type _]]) + [name type]))) + scopes)])))) + +(def: #export (un_alias def_name) + {#.doc "Given an aliased definition's name, returns the original definition being referenced."} + (-> Name (Meta Name)) + (do ..monad + [constant (..find_def def_name)] + (wrap (case constant + (#.Left real_def_name) + real_def_name + + (#.Right _) + def_name)))) + +(def: #export get_compiler + {#.doc "Obtains the current state of the compiler."} + (Meta Lux) + (function (_ compiler) + (#try.Success [compiler compiler]))) + +(def: #export type_context + (Meta Type_Context) + (function (_ compiler) + (#try.Success [compiler (get@ #.type_context compiler)]))) + +(def: #export (lift result) + (All [a] (-> (Try a) (Meta a))) + (case result + (#try.Success output) + (\ ..monad wrap output) + + (#try.Failure error) + (..fail error))) diff --git a/stdlib/source/library/lux/meta/annotation.lux b/stdlib/source/library/lux/meta/annotation.lux new file mode 100644 index 000000000..1b7ee480b --- /dev/null +++ b/stdlib/source/library/lux/meta/annotation.lux @@ -0,0 +1,95 @@ +(.module: + [library + [lux (#- nat int rev) + [abstract + ["." monad (#+ do)]] + [data + ["." maybe] + ["." name ("#\." equivalence)]]]]) + +(type: #export Annotation + Code) + +(def: #export (value tag ann) + (-> Name Annotation (Maybe Code)) + (case ann + [_ (#.Record ann)] + (loop [ann ann] + (case ann + (#.Cons [key value] ann') + (case key + [_ (#.Tag tag')] + (if (name\= tag tag') + (#.Some value) + (recur ann')) + + _ + (recur ann')) + + #.Nil + #.None)) + + _ + #.None)) + +(template [<name> <tag> <type>] + [(def: #export (<name> tag ann) + (-> Name Annotation (Maybe <type>)) + (case (..value tag ann) + (#.Some [_ (<tag> value)]) + (#.Some value) + + _ + #.None))] + + [bit #.Bit Bit] + [nat #.Nat Nat] + [int #.Int Int] + [rev #.Rev Rev] + [frac #.Frac Frac] + [text #.Text Text] + [identifier #.Identifier Name] + [tag #.Tag Name] + [form #.Form (List Code)] + [tuple #.Tuple (List Code)] + [record #.Record (List [Code Code])] + ) + +(def: #export documentation + (-> Annotation (Maybe Text)) + (..text (name_of #.doc))) + +(def: #export (flagged? flag) + (-> Name Annotation Bit) + (|>> (..bit flag) (maybe.default false))) + +(template [<name> <tag>] + [(def: #export <name> + (-> Annotation Bit) + (..flagged? (name_of <tag>)))] + + [implementation? #.implementation?] + [recursive_type? #.type-rec?] + [signature? #.sig?] + ) + +(def: (parse_text input) + (-> Code (Maybe Text)) + (case input + [_ (#.Text actual_value)] + (#.Some actual_value) + + _ + #.None)) + +(template [<name> <tag>] + [(def: #export (<name> ann) + (-> Annotation (List Text)) + (maybe.default (list) + (do {! maybe.monad} + [args (..tuple (name_of <tag>) ann)] + (monad.map ! ..parse_text args))))] + + [function_arguments #.func-args] + [type_arguments #.type-args] + ) diff --git a/stdlib/source/library/lux/meta/location.lux b/stdlib/source/library/lux/meta/location.lux new file mode 100644 index 000000000..ddc40b147 --- /dev/null +++ b/stdlib/source/library/lux/meta/location.lux @@ -0,0 +1,49 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)]]]]) + +(implementation: #export equivalence + (Equivalence Location) + + (def: (= reference subject) + (and ("lux text =" (get@ #.module reference) (get@ #.module subject)) + ("lux i64 =" (get@ #.line reference) (get@ #.line subject)) + ("lux i64 =" (get@ #.column reference) (get@ #.column subject))))) + +(def: #export dummy + Location + {#.module "" + #.line 0 + #.column 0}) + +(macro: #export (here tokens compiler) + (case tokens + #.Nil + (let [location (get@ #.location compiler)] + (#.Right [compiler + (list (` [(~ [..dummy (#.Text (get@ #.module location))]) + (~ [..dummy (#.Nat (get@ #.line location))]) + (~ [..dummy (#.Nat (get@ #.column location))])]))])) + + _ + (#.Left (`` (("lux in-module" (~~ (static .prelude_module)) wrong_syntax_error) (name_of ..here)))))) + +(def: #export (format value) + (-> Location Text) + (let [separator "," + [file line column] value] + ($_ "lux text concat" + "@" + (`` (("lux in-module" (~~ (static .prelude_module)) .text\encode) file)) separator + (`` (("lux in-module" (~~ (static .prelude_module)) .nat\encode) line)) separator + (`` (("lux in-module" (~~ (static .prelude_module)) .nat\encode) column))))) + +(def: \n + ("lux i64 char" +10)) + +(def: #export (with location error) + (-> Location Text Text) + ($_ "lux text concat" (..format location) \n + error)) diff --git a/stdlib/source/library/lux/program.lux b/stdlib/source/library/lux/program.lux new file mode 100644 index 000000000..bd486796b --- /dev/null +++ b/stdlib/source/library/lux/program.lux @@ -0,0 +1,83 @@ +(.module: + [library + [lux #* + ["@" target] + [abstract + [monad (#+ do)]] + [control + ["." io] + [concurrency + ["." thread]] + ["<>" parser + ["<.>" code] + ["<.>" cli]]] + [data + ["." text] + [collection + ["." list ("#\." monad)]]] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code]]]]) + +(type: Arguments + (#Raw Text) + (#Parsed (List [Code Code]))) + +(def: arguments^ + (<code>.Parser Arguments) + (<>.or <code>.local_identifier + (<code>.tuple (<>.some (<>.either (do <>.monad + [name <code>.local_identifier] + (wrap [(code.identifier ["" name]) (` (~! <cli>.any))])) + (<code>.record (<>.and <code>.any <code>.any))))))) + +(syntax: #export (program: + {args ..arguments^} + body) + {#.doc (doc "Defines the entry-point to a program (similar to the 'main' function/method in other programming languages)." + "Can take a list of all the input parameters to the program." + "Or, can destructure them using CLI-option combinators from the lux/control/parser/cli module." + (program: all_args + (do io.monad + [foo init_program + bar (do_something all_args)] + (wrap []))) + + (program: [name] + (io (log! (\ text.monoid compose "Hello, " name)))) + + (program: [{config configuration_parser}] + (do io.monad + [data (init_program config)] + (do_something data))))} + (with_gensyms [g!program g!args g!_ g!output g!message] + (let [initialization+event_loop + (` ((~! do) (~! io.monad) + [(~ g!output) (~ body) + (~+ (for {@.old (list) + @.jvm (list) + @.js (list) + @.python (list)} + (list g!_ (` (~! thread.run!)))))] + ((~' wrap) (~ g!output))))] + (wrap (list (` ("lux def program" + (~ (case args + (#Raw args) + (` (.function ((~ g!program) (~ (code.identifier ["" args]))) + (~ initialization+event_loop))) + + (#Parsed args) + (` (.function ((~ g!program) (~ g!args)) + (case ((~! <cli>.run) (: (~! (<cli>.Parser (io.IO .Any))) + ((~! do) (~! <>.monad) + [(~+ (|> args + (list\map (function (_ [binding parser]) + (list binding parser))) + list\join))] + ((~' wrap) (~ initialization+event_loop)))) + (~ g!args)) + (#.Right (~ g!output)) + (~ g!output) + + (#.Left (~ g!message)) + (.error! (~ g!message)))))))))))))) diff --git a/stdlib/source/library/lux/target.lux b/stdlib/source/library/lux/target.lux new file mode 100644 index 000000000..323cf812b --- /dev/null +++ b/stdlib/source/library/lux/target.lux @@ -0,0 +1,26 @@ +(.module: + [library + lux]) + +(type: #export Target + Text) + +(template [<name> <value>] + [(def: #export <name> + Target + <value>)] + + ## TODO: Delete ASAP. + [old "{old}"] + ## Available. + [js "JavaScript"] + [jvm "JVM"] + [lua "Lua"] + [python "Python"] + [ruby "Ruby"] + ## Not available yet. + [common_lisp "Common Lisp"] + [php "PHP"] + [r "R"] + [scheme "Scheme"] + ) diff --git a/stdlib/source/library/lux/target/common_lisp.lux b/stdlib/source/library/lux/target/common_lisp.lux new file mode 100644 index 000000000..2ec6746c2 --- /dev/null +++ b/stdlib/source/library/lux/target/common_lisp.lux @@ -0,0 +1,469 @@ +(.module: + [library + [lux (#- Code int if cond or and comment let) + [control + [pipe (#+ case> cond> new>)]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." monad fold monoid)]]] + [macro + ["." template]] + [math + [number + ["f" frac]]] + [type + abstract]]]) + +(def: as_form + (-> Text Text) + (text.enclose ["(" ")"])) + +(abstract: #export (Code brand) + Text + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (template [<type> <super>] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (`` (abstract: #export (<brand> brand) Any)) + (`` (type: #export (<type> brand) + (<super> (<brand> brand)))))] + + [Expression Code] + [Computation Expression] + [Access Computation] + [Var Access] + + [Input Code] + ) + + (template [<type> <super>] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (`` (abstract: #export <brand> Any)) + (`` (type: #export <type> (<super> <brand>))))] + + [Label Code] + [Tag Expression] + [Literal Expression] + [Var/1 Var] + [Var/* Input] + ) + + (type: #export Lambda + {#input Var/* + #output (Expression Any)}) + + (def: #export nil + Literal + (:abstraction "()")) + + (template [<prefix> <name>] + [(def: #export <name> + (-> Text Literal) + (|>> (format <prefix>) :abstraction))] + + ["'" symbol] + [":" keyword]) + + (def: #export bool + (-> Bit Literal) + (|>> (case> #0 ..nil + #1 (..symbol "t")))) + + (def: #export int + (-> Int Literal) + (|>> %.int :abstraction)) + + (def: #export float + (-> Frac Literal) + (|>> (cond> [(f.= f.positive_infinity)] + [(new> "(/ 1.0 0.0)" [])] + + [(f.= f.negative_infinity)] + [(new> "(/ -1.0 0.0)" [])] + + [f.not_a_number?] + [(new> "(/ 0.0 0.0)" [])] + + ## else + [%.frac]) + :abstraction)) + + (def: #export (double value) + (-> Frac Literal) + (:abstraction + (.cond (f.= f.positive_infinity value) + "(/ 1.0d0 0.0d0)" + + (f.= f.negative_infinity value) + "(/ -1.0d0 0.0d0)" + + (f.not_a_number? value) + "(/ 0.0d0 0.0d0)" + + ## else + (.let [raw (%.frac value)] + (.if (text.contains? "E" raw) + (text.replace_once "E" "d" raw) + (format raw "d0")))))) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [<find> <replace>] + [(text.replace_all <find> <replace>)] + + ["\" "\\"] + [text.tab "\t"] + [text.vertical_tab "\v"] + [text.null "\0"] + [text.back_space "\b"] + [text.form_feed "\f"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] + )) + ))) + + (def: #export string + (-> Text Literal) + (|>> ..sanitize + (text.enclose' text.double_quote) + :abstraction)) + + (def: #export var + (-> Text Var/1) + (|>> :abstraction)) + + (def: #export args + (-> (List Var/1) Var/*) + (|>> (list\map ..code) + (text.join_with " ") + ..as_form + :abstraction)) + + (def: #export (args& singles rest) + (-> (List Var/1) Var/1 Var/*) + (|> (case singles + #.Nil + "" + + (#.Cons _) + (|> singles + (list\map ..code) + (text.join_with " ") + (text.suffix " "))) + (format "&rest " (:representation rest)) + ..as_form + :abstraction)) + + (def: form + (-> (List (Expression Any)) Expression) + (|>> (list\map ..code) + (text.join_with " ") + ..as_form + :abstraction)) + + (def: #export (call/* func) + (-> (Expression Any) (-> (List (Expression Any)) (Computation Any))) + (|>> (#.Cons func) ..form)) + + (template [<name> <function>] + [(def: #export <name> + (-> (List (Expression Any)) (Computation Any)) + (..call/* (..var <function>)))] + + [vector/* "vector"] + [list/* "list"] + ) + + (def: #export (labels definitions body) + (-> (List [Var/1 Lambda]) (Expression Any) (Computation Any)) + (..form (list (..var "labels") + (..form (list\map (function (_ [def_name [def_args def_body]]) + (..form (list def_name (:transmutation def_args) def_body))) + definitions)) + body))) + + (def: #export (destructuring-bind [bindings expression] body) + (-> [Var/* (Expression Any)] (List (Expression Any)) (Computation Any)) + (..form (list& (..var "destructuring-bind") + (:transmutation bindings) expression + body))) + + (template [<call> <input_var>+ <input_type>+ <function>+] + [(`` (def: #export (<call> [(~~ (template.splice <input_var>+))] function) + (-> [(~~ (template.splice <input_type>+))] (Expression Any) (Computation Any)) + (..call/* function (list (~~ (template.splice <input_var>+)))))) + + (`` (template [<lux_name> <host_name>] + [(def: #export (<lux_name> args) + (-> [(~~ (template.splice <input_type>+))] (Computation Any)) + (<call> args (..var <host_name>)))] + + (~~ (template.splice <function>+))))] + + [call/0 [] [] + [[get-universal-time/0 "get-universal-time"] + [make-hash-table/0 "make-hash-table"]]] + [call/1 [in0] [(Expression Any)] + [[length/1 "length"] + [function/1 "function"] + [copy-seq/1 "copy-seq"] + [null/1 "null"] + [error/1 "error"] + [not/1 "not"] + [floor/1 "floor"] + [type-of/1 "type-of"] + [write-to-string/1 "write-to-string"] + [read-from-string/1 "read-from-string"] + [print/1 "print"] + [reverse/1 "reverse"] + [sxhash/1 "sxhash"] + [string-upcase/1 "string-upcase"] + [string-downcase/1 "string-downcase"] + [char-int/1 "char-int"] + [text/1 "text"] + [hash-table-size/1 "hash-table-size"] + [hash-table-rehash-size/1 "hash-table-rehash-size"] + [code-char/1 "code-char"] + [char-code/1 "char-code"] + [string/1 "string"] + [write-line/1 "write-line"] + [pprint/1 "pprint"] + [identity/1 "identity"]]] + [call/2 [in0 in1] [(Expression Any) (Expression Any)] + [[apply/2 "apply"] + [append/2 "append"] + [cons/2 "cons"] + [char/2 "char"] + [nth/2 "nth"] + [nthcdr/2 "nthcdr"] + [coerce/2 "coerce"] + [eq/2 "eq"] + [equal/2 "equal"] + [string=/2 "string="] + [=/2 "="] + [+/2 "+"] + [*/2 "*"]]] + [call/3 [in0 in1 in2] [(Expression Any) (Expression Any) (Expression Any)] + [[subseq/3 "subseq"] + [map/3 "map"] + [concatenate/3 "concatenate"] + [format/3 "format"]]] + ) + + (template [<call> <input_type>+ <function>+] + [(`` (template [<lux_name> <host_name>] + [(def: #export (<lux_name> args) + (-> [(~~ (template.splice <input_type>+))] (Access Any)) + (:transmutation (<call> args (..var <host_name>))))] + + (~~ (template.splice <function>+))))] + + [call/1 [(Expression Any)] + [[car/1 "car"] + [cdr/1 "cdr"] + [cadr/1 "cadr"] + [cddr/1 "cddr"]]] + [call/2 [(Expression Any) (Expression Any)] + [[svref/2 "svref"] + [elt/2 "elt"] + [gethash/2 "gethash"]]] + ) + + (def: #export (make-hash-table/with_size size) + (-> (Expression Any) (Computation Any)) + (..call/* (..var "make-hash-table") + (list (..keyword "size") + size))) + + (def: #export (funcall/+ [func args]) + (-> [(Expression Any) (List (Expression Any))] (Computation Any)) + (..call/* (..var "funcall") (list& func args))) + + (def: #export (search/3 [reference space start]) + (-> [(Expression Any) (Expression Any) (Expression Any)] (Computation Any)) + (..call/* (..var "search") + (list reference + space + (..keyword "start2") start))) + + (def: #export (concatenate/2|string [left right]) + (-> [(Expression Any) (Expression Any)] (Computation Any)) + (concatenate/3 [(..symbol "string") left right])) + + (template [<lux_name> <host_name>] + [(def: #export (<lux_name> left right) + (-> (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var <host_name>) left right)))] + + [or "or"] + [and "and"] + ) + + (template [<lux_name> <host_name>] + [(def: #export (<lux_name> [param subject]) + (-> [(Expression Any) (Expression Any)] (Computation Any)) + (..form (list (..var <host_name>) subject param)))] + + [</2 "<"] + [<=/2 "<="] + [>/2 ">"] + [>=/2 ">="] + [string</2 "string<"] + [-/2 "-"] + [//2 "/"] + [rem/2 "rem"] + [floor/2 "floor"] + [mod/2 "mod"] + [ash/2 "ash"] + [logand/2 "logand"] + [logior/2 "logior"] + [logxor/2 "logxor"] + ) + + (def: #export (if test then else) + (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var "if") test then else))) + + (def: #export (when test then) + (-> (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var "when") test then))) + + (def: #export (lambda input body) + (-> Var/* (Expression Any) Literal) + (..form (list (..var "lambda") (:transmutation input) body))) + + (template [<lux_name> <host_name>] + [(def: #export (<lux_name> bindings body) + (-> (List [Var/1 (Expression Any)]) (List (Expression Any)) (Computation Any)) + (..form (list& (..var <host_name>) + (|> bindings + (list\map (function (_ [name value]) + (..form (list name value)))) + ..form) + body)))] + + [let "let"] + [let* "let*"] + ) + + (def: #export (defparameter name body) + (-> Var/1 (Expression Any) (Expression Any)) + (..form (list (..var "defparameter") name body))) + + (def: #export (defun name inputs body) + (-> Var/1 Var/* (Expression Any) (Expression Any)) + (..form (list (..var "defun") name (:transmutation inputs) body))) + + (template [<name> <symbol>] + [(def: #export <name> + (-> (List (Expression Any)) (Computation Any)) + (|>> (list& (..var <symbol>)) ..form))] + + [progn "progn"] + [tagbody "tagbody"] + [values/* "values"] + ) + + (def: #export (setq name value) + (-> Var/1 (Expression Any) (Expression Any)) + (..form (list (..var "setq") name value))) + + (def: #export (setf access value) + (-> (Access Any) (Expression Any) (Expression Any)) + (..form (list (..var "setf") access value))) + + (type: #export Handler + {#condition_type (Expression Any) + #condition Var/1 + #body (Expression Any)}) + + (def: #export (handler-case handlers body) + (-> (List Handler) (Expression Any) (Computation Any)) + (..form (list& (..var "handler-case") + body + (list\map (function (_ [type condition handler]) + (..form (list type + (:transmutation (..args (list condition))) + handler))) + handlers)))) + + (template [<name> <prefix>] + [(def: #export (<name> conditions expression) + (-> (List Text) (Expression Any) (Expression Any)) + (case conditions + #.Nil + expression + + (#.Cons single #.Nil) + (:abstraction + (format <prefix> single " " (:representation expression))) + + _ + (:abstraction + (format <prefix> (|> conditions (list\map ..symbol) + (list& (..symbol "or")) ..form + :representation) + " " (:representation expression)))))] + + [conditional+ "#+"] + [conditional- "#-"]) + + (def: #export label + (-> Text Label) + (|>> :abstraction)) + + (def: #export (block name body) + (-> Label (List (Expression Any)) (Computation Any)) + (..form (list& (..var "block") (:transmutation name) body))) + + (def: #export (return-from target value) + (-> Label (Expression Any) (Computation Any)) + (..form (list (..var "return-from") (:transmutation target) value))) + + (def: #export (return value) + (-> (Expression Any) (Computation Any)) + (..form (list (..var "return") value))) + + (def: #export (cond clauses else) + (-> (List [(Expression Any) (Expression Any)]) (Expression Any) (Computation Any)) + (..form (list& (..var "cond") + (list\compose (list\map (function (_ [test then]) + (..form (list test then))) + clauses) + (list (..form (list (..bool true) else))))))) + + (def: #export tag + (-> Text Tag) + (|>> :abstraction)) + + (def: #export go + (-> Tag (Expression Any)) + (|>> (list (..var "go")) + ..form)) + + (def: #export values-list/1 + (-> (Expression Any) (Expression Any)) + (|>> (list (..var "values-list")) + ..form)) + + (def: #export (multiple-value-setq bindings values) + (-> Var/* (Expression Any) (Expression Any)) + (..form (list (..var "multiple-value-setq") + (:transmutation bindings) + values))) + ) + +(def: #export (while condition body) + (-> (Expression Any) (Expression Any) (Computation Any)) + (..form (list (..var "loop") (..var "while") condition + (..var "do") body))) diff --git a/stdlib/source/library/lux/target/js.lux b/stdlib/source/library/lux/target/js.lux new file mode 100644 index 000000000..d7b42280c --- /dev/null +++ b/stdlib/source/library/lux/target/js.lux @@ -0,0 +1,449 @@ +(.module: + [library + [lux (#- Location Code or and function if cond undefined for comment not int try) + [control + [pipe (#+ case>)]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [macro + ["." template]] + [math + [number + ["i" int] + ["f" frac]]] + [type + abstract]]]) + +(def: expression (text.enclose ["(" ")"])) +(def: element (text.enclose ["[" "]"])) + +(def: nest + (-> Text Text) + (|>> (format text.new_line) + (text.replace_all text.new_line (format text.new_line text.tab)))) + +(abstract: #export (Code brand) + Text + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (template [<type> <super>+] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (abstract: (<brand> brand) Any) + (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))] + + [Expression [Code]] + [Computation [Expression' Code]] + [Location [Computation' Expression' Code]] + [Statement [Code]] + ) + + (template [<type> <super>+] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (abstract: #export <brand> Any) + (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))] + + [Var [Location' Computation' Expression' Code]] + [Access [Location' Computation' Expression' Code]] + [Literal [Computation' Expression' Code]] + [Loop [Statement' Code]] + [Label [Code]] + ) + + (template [<name> <literal>] + [(def: #export <name> Literal (:abstraction <literal>))] + + [null "null"] + [undefined "undefined"] + ) + + (def: #export boolean + (-> Bit Literal) + (|>> (case> + #0 "false" + #1 "true") + :abstraction)) + + (def: #export (number value) + (-> Frac Literal) + (:abstraction + (.cond (f.not_a_number? value) + "NaN" + + (f.= f.positive_infinity value) + "Infinity" + + (f.= f.negative_infinity value) + "-Infinity" + + ## else + (|> value %.frac ..expression)))) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [<replace> <find>] + [(text.replace_all <find> <replace>)] + + ["\\" "\"] + ["\t" text.tab] + ["\v" text.vertical_tab] + ["\0" text.null] + ["\b" text.back_space] + ["\f" text.form_feed] + ["\n" text.new_line] + ["\r" text.carriage_return] + [(format "\" text.double_quote) + text.double_quote] + )) + ))) + + (def: #export string + (-> Text Literal) + (|>> ..sanitize + (text.enclose [text.double_quote text.double_quote]) + :abstraction)) + + (def: argument_separator ", ") + (def: field_separator ": ") + (def: statement_suffix ";") + + (def: #export array + (-> (List Expression) Computation) + (|>> (list\map ..code) + (text.join_with ..argument_separator) + ..element + :abstraction)) + + (def: #export var + (-> Text Var) + (|>> :abstraction)) + + (def: #export (at index array_or_object) + (-> Expression Expression Access) + (:abstraction (format (:representation array_or_object) (..element (:representation index))))) + + (def: #export (the field object) + (-> Text Expression Access) + (:abstraction (format (:representation object) "." field))) + + (def: #export (apply/* function inputs) + (-> Expression (List Expression) Computation) + (|> inputs + (list\map ..code) + (text.join_with ..argument_separator) + ..expression + (format (:representation function)) + :abstraction)) + + (def: #export (do method inputs object) + (-> Text (List Expression) Expression Computation) + (apply/* (..the method object) inputs)) + + (def: #export object + (-> (List [Text Expression]) Computation) + (|>> (list\map (.function (_ [key val]) + (format (:representation (..string key)) ..field_separator (:representation val)))) + (text.join_with ..argument_separator) + (text.enclose ["{" "}"]) + ..expression + :abstraction)) + + (def: #export (, pre post) + (-> Expression Expression Computation) + (|> (format (:representation pre) ..argument_separator (:representation post)) + ..expression + :abstraction)) + + (def: #export (then pre post) + (-> Statement Statement Statement) + (:abstraction (format (:representation pre) + text.new_line + (:representation post)))) + + (def: block + (-> Statement Text) + (let [close (format text.new_line "}")] + (|>> :representation + ..nest + (text.enclose ["{" + close])))) + + (def: #export (function! name inputs body) + (-> Var (List Var) Statement Statement) + (|> body + ..block + (format "function " (:representation name) + (|> inputs + (list\map ..code) + (text.join_with ..argument_separator) + ..expression) + " ") + :abstraction)) + + (def: #export (function name inputs body) + (-> Var (List Var) Statement Computation) + (|> (..function! name inputs body) + :representation + ..expression + :abstraction)) + + (def: #export (closure inputs body) + (-> (List Var) Statement Computation) + (|> body + ..block + (format "function" + (|> inputs + (list\map ..code) + (text.join_with ..argument_separator) + ..expression) + " ") + ..expression + :abstraction)) + + (template [<name> <op>] + [(def: #export (<name> param subject) + (-> Expression Expression Computation) + (|> (format (:representation subject) " " <op> " " (:representation param)) + ..expression + :abstraction))] + + [= "==="] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + + [+ "+"] + [- "-"] + [* "*"] + [/ "/"] + [% "%"] + + [left_shift "<<"] + [arithmetic_right_shift ">>"] + [logic_right_shift ">>>"] + + [or "||"] + [and "&&"] + [bit_xor "^"] + [bit_or "|"] + [bit_and "&"] + ) + + (template [<name> <prefix>] + [(def: #export <name> + (-> Expression Computation) + (|>> :representation (text.prefix <prefix>) ..expression :abstraction))] + + [not "!"] + [bit_not "~"] + [negate "-"] + ) + + (template [<name> <input> <format>] + [(def: #export (<name> value) + {#.doc "A 32-bit integer expression."} + (-> <input> Computation) + (:abstraction (..expression (format (<format> value) "|0"))))] + + [to_i32 Expression :representation] + [i32 Int %.int] + ) + + (def: #export (int value) + (-> Int Literal) + (:abstraction (.if (i.< +0 value) + (%.int value) + (%.nat (.nat value))))) + + (def: #export (? test then else) + (-> Expression Expression Expression Computation) + (|> (format (:representation test) + " ? " (:representation then) + " : " (:representation else)) + ..expression + :abstraction)) + + (def: #export type_of + (-> Expression Computation) + (|>> :representation + (format "typeof ") + ..expression + :abstraction)) + + (def: #export (new constructor inputs) + (-> Expression (List Expression) Computation) + (|> (format "new " (:representation constructor) + (|> inputs + (list\map ..code) + (text.join_with ..argument_separator) + ..expression)) + ..expression + :abstraction)) + + (def: #export statement + (-> Expression Statement) + (|>> :representation (text.suffix ..statement_suffix) :abstraction)) + + (def: #export use_strict + Statement + (:abstraction (format text.double_quote "use strict" text.double_quote ..statement_suffix))) + + (def: #export (declare name) + (-> Var Statement) + (:abstraction (format "var " (:representation name) ..statement_suffix))) + + (def: #export (define name value) + (-> Var Expression Statement) + (:abstraction (format "var " (:representation name) " = " (:representation value) ..statement_suffix))) + + (def: #export (set' name value) + (-> Location Expression Expression) + (:abstraction (..expression (format (:representation name) " = " (:representation value))))) + + (def: #export (set name value) + (-> Location Expression Statement) + (:abstraction (format (:representation name) " = " (:representation value) ..statement_suffix))) + + (def: #export (throw message) + (-> Expression Statement) + (:abstraction (format "throw " (:representation message) ..statement_suffix))) + + (def: #export (return value) + (-> Expression Statement) + (:abstraction (format "return " (:representation value) ..statement_suffix))) + + (def: #export (delete' value) + (-> Location Expression) + (:abstraction (format "delete " (:representation value)))) + + (def: #export (delete value) + (-> Location Statement) + (:abstraction (format (:representation (delete' value)) ..statement_suffix))) + + (def: #export (if test then! else!) + (-> Expression Statement Statement Statement) + (:abstraction (format "if(" (:representation test) ") " + (..block then!) + " else " + (..block else!)))) + + (def: #export (when test then!) + (-> Expression Statement Statement) + (:abstraction (format "if(" (:representation test) ") " + (..block then!)))) + + (def: #export (while test body) + (-> Expression Statement Loop) + (:abstraction (format "while(" (:representation test) ") " + (..block body)))) + + (def: #export (do_while test body) + (-> Expression Statement Loop) + (:abstraction (format "do " (..block body) + " while(" (:representation test) ")" ..statement_suffix))) + + (def: #export (try body [exception catch]) + (-> Statement [Var Statement] Statement) + (:abstraction (format "try " + (..block body) + " catch(" (:representation exception) ") " + (..block catch)))) + + (def: #export (for var init condition update iteration) + (-> Var Expression Expression Expression Statement Loop) + (:abstraction (format "for(" (:representation (..define var init)) + " " (:representation condition) + ..statement_suffix " " (:representation update) + ")" + (..block iteration)))) + + (def: #export label + (-> Text Label) + (|>> :abstraction)) + + (def: #export (with_label label loop) + (-> Label Loop Statement) + (:abstraction (format (:representation label) ": " (:representation loop)))) + + (template [<keyword> <0> <1>] + [(def: #export <0> + Statement + (:abstraction (format <keyword> ..statement_suffix))) + + (def: #export (<1> label) + (-> Label Statement) + (:abstraction (format <keyword> " " (:representation label) ..statement_suffix)))] + + ["break" break break_at] + ["continue" continue continue_at] + ) + + (template [<name> <js>] + [(def: #export <name> + (-> Location Expression) + (|>> :representation + (text.suffix <js>) + :abstraction))] + + [++ "++"] + [-- "--"] + ) + + (def: #export (comment commentary on) + (All [kind] (-> Text (Code kind) (Code kind))) + (:abstraction (format "/* " commentary " */" " " (:representation on)))) + + (def: #export (switch input cases default) + (-> Expression (List [(List Literal) Statement]) (Maybe Statement) Statement) + (:abstraction (format "switch (" (:representation input) ") " + (|> (format (|> cases + (list\map (.function (_ [when then]) + (format (|> when + (list\map (|>> :representation (text.enclose ["case " ":"]))) + (text.join_with text.new_line)) + (..nest (:representation then))))) + (text.join_with text.new_line)) + text.new_line + (case default + (#.Some default) + (format "default:" + (..nest (:representation default))) + + #.None "")) + :abstraction + ..block)))) + ) + +(def: #export (cond clauses else!) + (-> (List [Expression Statement]) Statement Statement) + (list\fold (.function (_ [test then!] next!) + (..if test then! next!)) + else! + (list.reverse clauses))) + +(template [<apply> <arg>+ <type>+ <function>+] + [(`` (def: #export (<apply> function) + (-> Expression (~~ (template.splice <type>+)) Computation) + (.function (_ (~~ (template.splice <arg>+))) + (..apply/* function (list (~~ (template.splice <arg>+))))))) + + (`` (template [<definition> <function>] + [(def: #export <definition> (<apply> (..var <function>)))] + + (~~ (template.splice <function>+))))] + + [apply/1 [_0] [Expression] + [[not_a_number? "isNaN"]]] + + [apply/2 [_0 _1] [Expression Expression] + []] + + [apply/3 [_0 _1 _2] [Expression Expression Expression] + []] + ) diff --git a/stdlib/source/library/lux/target/jvm.lux b/stdlib/source/library/lux/target/jvm.lux new file mode 100644 index 000000000..b470abea9 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm.lux @@ -0,0 +1,284 @@ +(.module: + [library + [lux (#- Type) + [data + [collection + [row (#+ Row)]]] + [target + [jvm + [type (#+ Type) + ["." category (#+ Primitive Class Value Method)]]]]]]) + +(type: #export Literal + (#Boolean Bit) + (#Int Int) + (#Long Int) + (#Double Frac) + (#Char Nat) + (#String Text)) + +(type: #export Constant + (#BIPUSH Int) + + (#SIPUSH Int) + + #ICONST_M1 + #ICONST_0 + #ICONST_1 + #ICONST_2 + #ICONST_3 + #ICONST_4 + #ICONST_5 + + #LCONST_0 + #LCONST_1 + + #FCONST_0 + #FCONST_1 + #FCONST_2 + + #DCONST_0 + #DCONST_1 + + #ACONST_NULL + + (#LDC Literal)) + +(type: #export Int_Arithmetic + #IADD + #ISUB + #IMUL + #IDIV + #IREM + #INEG) + +(type: #export Long_Arithmetic + #LADD + #LSUB + #LMUL + #LDIV + #LREM + #LNEG) + +(type: #export Float_Arithmetic + #FADD + #FSUB + #FMUL + #FDIV + #FREM + #FNEG) + +(type: #export Double_Arithmetic + #DADD + #DSUB + #DMUL + #DDIV + #DREM + #DNEG) + +(type: #export Arithmetic + (#Int_Arithmetic Int_Arithmetic) + (#Long_Arithmetic Long_Arithmetic) + (#Float_Arithmetic Float_Arithmetic) + (#Double_Arithmetic Double_Arithmetic)) + +(type: #export Int_Bitwise + #IOR + #IXOR + #IAND + #ISHL + #ISHR + #IUSHR) + +(type: #export Long_Bitwise + #LOR + #LXOR + #LAND + #LSHL + #LSHR + #LUSHR) + +(type: #export Bitwise + (#Int_Bitwise Int_Bitwise) + (#Long_Bitwise Long_Bitwise)) + +(type: #export Conversion + #I2B + #I2S + #I2L + #I2F + #I2D + #I2C + + #L2I + #L2F + #L2D + + #F2I + #F2L + #F2D + + #D2I + #D2L + #D2F) + +(type: #export Array + #ARRAYLENGTH + + (#NEWARRAY (Type Primitive)) + (#ANEWARRAY (Type category.Object)) + + #BALOAD + #BASTORE + + #SALOAD + #SASTORE + + #IALOAD + #IASTORE + + #LALOAD + #LASTORE + + #FALOAD + #FASTORE + + #DALOAD + #DASTORE + + #CALOAD + #CASTORE + + #AALOAD + #AASTORE) + +(type: #export Object + (#GETSTATIC (Type Class) Text (Type Value)) + (#PUTSTATIC (Type Class) Text (Type Value)) + + (#NEW (Type Class)) + + (#INSTANCEOF (Type Class)) + (#CHECKCAST (Type category.Object)) + + (#GETFIELD (Type Class) Text (Type Value)) + (#PUTFIELD (Type Class) Text (Type Value)) + + (#INVOKEINTERFACE (Type Class) Text (Type Method)) + (#INVOKESPECIAL (Type Class) Text (Type Method)) + (#INVOKESTATIC (Type Class) Text (Type Method)) + (#INVOKEVIRTUAL (Type Class) Text (Type Method))) + +(type: #export Register Nat) + +(type: #export Local_Int + (#ILOAD Register) + (#ISTORE Register)) + +(type: #export Local_Long + (#LLOAD Register) + (#LSTORE Register)) + +(type: #export Local_Float + (#FLOAD Register) + (#FSTORE Register)) + +(type: #export Local_Double + (#DLOAD Register) + (#DSTORE Register)) + +(type: #export Local_Object + (#ALOAD Register) + (#ASTORE Register)) + +(type: #export Local + (#Local_Int Local_Int) + (#IINC Register) + (#Local_Long Local_Long) + (#Local_Float Local_Float) + (#Local_Double Local_Double) + (#Local_Object Local_Object)) + +(type: #export Stack + #DUP + #DUP_X1 + #DUP_X2 + #DUP2 + #DUP2_X1 + #DUP2_X2 + #SWAP + #POP + #POP2) + +(type: #export Comparison + #LCMP + + #FCMPG + #FCMPL + + #DCMPG + #DCMPL) + +(type: #export Label Nat) + +(type: #export (Branching label) + (#IF_ICMPEQ label) + (#IF_ICMPGE label) + (#IF_ICMPGT label) + (#IF_ICMPLE label) + (#IF_ICMPLT label) + (#IF_ICMPNE label) + (#IFEQ label) + (#IFNE label) + (#IFGE label) + (#IFGT label) + (#IFLE label) + (#IFLT label) + + (#TABLESWITCH Int Int label (List label)) + (#LOOKUPSWITCH label (List [Int label])) + + (#IF_ACMPEQ label) + (#IF_ACMPNE label) + (#IFNONNULL label) + (#IFNULL label)) + +(type: #export (Exception label) + (#Try label label label (Type Class)) + #ATHROW) + +(type: #export Concurrency + #MONITORENTER + #MONITOREXIT) + +(type: #export Return + #RETURN + #IRETURN + #LRETURN + #FRETURN + #DRETURN + #ARETURN) + +(type: #export (Control label) + (#GOTO label) + (#Branching (Branching label)) + (#Exception (Exception label)) + (#Concurrency Concurrency) + (#Return Return)) + +(type: #export (Instruction embedded label) + #NOP + (#Constant Constant) + (#Arithmetic Arithmetic) + (#Bitwise Bitwise) + (#Conversion Conversion) + (#Array Array) + (#Object Object) + (#Local Local) + (#Stack Stack) + (#Comparison Comparison) + (#Control (Control label)) + (#Embedded embedded)) + +(type: #export (Bytecode embedded label) + (Row (Instruction embedded label))) diff --git a/stdlib/source/library/lux/target/jvm/attribute.lux b/stdlib/source/library/lux/target/jvm/attribute.lux new file mode 100644 index 000000000..9869a6f8b --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/attribute.lux @@ -0,0 +1,123 @@ +(.module: + [library + [lux (#- Info Code) + [abstract + [monad (#+ do)] + ["." equivalence (#+ Equivalence)]] + [control + ["." try] + ["." exception (#+ exception:)]] + [data + ["." sum] + ["." product] + [format + [".F" binary (#+ Writer)]]] + [math + [number + ["n" nat]]]]] + ["." // #_ + ["#." index (#+ Index)] + [encoding + ["#." unsigned (#+ U2 U4)]] + ["#." constant (#+ UTF8 Class Value) + ["#/." pool (#+ Pool Resource)]]] + ["." / #_ + ["#." constant (#+ Constant)] + ["#." code]]) + +(type: #export (Info about) + {#name (Index UTF8) + #length U4 + #info about}) + +(def: #export (info_equivalence Equivalence<about>) + (All [about] + (-> (Equivalence about) + (Equivalence (Info about)))) + ($_ product.equivalence + //index.equivalence + //unsigned.equivalence + Equivalence<about>)) + +(def: (info_writer writer) + (All [about] + (-> (Writer about) + (Writer (Info about)))) + (function (_ [name length info]) + (let [[nameS nameT] (//index.writer name) + [lengthS lengthT] (//unsigned.writer/4 length) + [infoS infoT] (writer info)] + [($_ n.+ nameS lengthS infoS) + (|>> nameT lengthT infoT)]))) + +(with_expansions [<Code> (as_is (/code.Code Attribute))] + (type: #export #rec Attribute + (#Constant (Info (Constant Any))) + (#Code (Info <Code>))) + + (type: #export Code + <Code>) + ) + +(def: #export equivalence + (Equivalence Attribute) + (equivalence.rec + (function (_ equivalence) + ($_ sum.equivalence + (info_equivalence /constant.equivalence) + (info_equivalence (/code.equivalence equivalence)))))) + +(def: common_attribute_length + ($_ n.+ + ## u2 attribute_name_index; + //unsigned.bytes/2 + ## u4 attribute_length; + //unsigned.bytes/4 + )) + +(def: (length attribute) + (-> Attribute Nat) + (case attribute + (^template [<tag>] + [(<tag> [name length info]) + (|> length //unsigned.value (n.+ ..common_attribute_length))]) + ([#Constant] [#Code]))) + +## TODO: Inline ASAP +(def: (constant' @name index) + (-> (Index UTF8) (Constant Any) Attribute) + (#Constant {#name @name + #length (|> /constant.length //unsigned.u4 try.assume) + #info index})) + +(def: #export (constant index) + (-> (Constant Any) (Resource Attribute)) + (do //constant/pool.monad + [@name (//constant/pool.utf8 "ConstantValue")] + (wrap (constant' @name index)))) + +## TODO: Inline ASAP +(def: (code' @name specification) + (-> (Index UTF8) Code Attribute) + (#Code {#name @name + ## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3 + #length (|> specification + (/code.length ..length) + //unsigned.u4 + try.assume) + #info specification})) + +(def: #export (code specification) + (-> Code (Resource Attribute)) + (do //constant/pool.monad + [@name (//constant/pool.utf8 "Code")] + (wrap (code' @name specification)))) + +(def: #export (writer value) + (Writer Attribute) + (case value + (#Constant attribute) + ((info_writer /constant.writer) attribute) + + (#Code attribute) + ((info_writer (/code.writer writer)) attribute))) diff --git a/stdlib/source/library/lux/target/jvm/attribute/code.lux b/stdlib/source/library/lux/target/jvm/attribute/code.lux new file mode 100644 index 000000000..80cc7a6ad --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/attribute/code.lux @@ -0,0 +1,83 @@ +(.module: + [library + [lux (#- Code) + [type (#+ :share)] + [abstract + [equivalence (#+ Equivalence)]] + [data + ["." product] + ["." binary (#+ Binary)] + [format + [".F" binary (#+ Writer) ("#\." monoid)]] + [collection + ["." row (#+ Row) ("#\." functor fold)]]] + [math + [number + ["n" nat]]]]] + ["." /// #_ + [bytecode + [environment + ["#." limit (#+ Limit)]]] + [encoding + ["#." unsigned (#+ U2)]]] + ["." / #_ + ["#." exception (#+ Exception)]]) + +(type: #export (Code Attribute) + {#limit Limit + #code Binary + #exception_table (Row Exception) + #attributes (Row Attribute)}) + +(def: #export (length length code) + (All [Attribute] (-> (-> Attribute Nat) (Code Attribute) Nat)) + ($_ n.+ + ## u2 max_stack; + ## u2 max_locals; + ///limit.length + ## u4 code_length; + ///unsigned.bytes/4 + ## u1 code[code_length]; + (binary.size (get@ #code code)) + ## u2 exception_table_length; + ///unsigned.bytes/2 + ## exception_table[exception_table_length]; + (|> code + (get@ #exception_table) + row.size + (n.* /exception.length)) + ## u2 attributes_count; + ///unsigned.bytes/2 + ## attribute_info attributes[attributes_count]; + (|> code + (get@ #attributes) + (row\map length) + (row\fold n.+ 0)))) + +(def: #export (equivalence attribute_equivalence) + (All [attribute] + (-> (Equivalence attribute) (Equivalence (Code attribute)))) + ($_ product.equivalence + ///limit.equivalence + binary.equivalence + (row.equivalence /exception.equivalence) + (row.equivalence attribute_equivalence) + )) + +## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3 +(def: #export (writer writer code) + (All [Attribute] (-> (Writer Attribute) (Writer (Code Attribute)))) + ($_ binaryF\compose + ## u2 max_stack; + ## u2 max_locals; + (///limit.writer (get@ #limit code)) + ## u4 code_length; + ## u1 code[code_length]; + (binaryF.binary/32 (get@ #code code)) + ## u2 exception_table_length; + ## exception_table[exception_table_length]; + ((binaryF.row/16 /exception.writer) (get@ #exception_table code)) + ## u2 attributes_count; + ## attribute_info attributes[attributes_count]; + ((binaryF.row/16 writer) (get@ #attributes code)) + )) diff --git a/stdlib/source/library/lux/target/jvm/attribute/code/exception.lux b/stdlib/source/library/lux/target/jvm/attribute/code/exception.lux new file mode 100644 index 000000000..e2aa089b0 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/attribute/code/exception.lux @@ -0,0 +1,58 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [data + ["." product] + ["." format #_ + ["#" binary (#+ Writer)]]] + [math + [number + ["n" nat]]]]] + ["." // #_ + ["//#" /// #_ + [constant (#+ Class)] + ["#." index (#+ Index)] + [bytecode + ["#." address (#+ Address)]] + [encoding + ["#." unsigned (#+ U2)]]]]) + +(type: #export Exception + {#start Address + #end Address + #handler Address + #catch (Index Class)}) + +(def: #export equivalence + (Equivalence Exception) + ($_ product.equivalence + ////address.equivalence + ////address.equivalence + ////address.equivalence + ////index.equivalence + )) + +## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3 +(def: #export length + Nat + ($_ n.+ + ## u2 start_pc; + ////unsigned.bytes/2 + ## u2 end_pc; + ////unsigned.bytes/2 + ## u2 handler_pc; + ////unsigned.bytes/2 + ## u2 catch_type; + ////unsigned.bytes/2 + )) + +(def: #export writer + (Writer Exception) + ($_ format.and + ////address.writer + ////address.writer + ////address.writer + ////index.writer + )) diff --git a/stdlib/source/library/lux/target/jvm/attribute/constant.lux b/stdlib/source/library/lux/target/jvm/attribute/constant.lux new file mode 100644 index 000000000..d9f26d418 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/attribute/constant.lux @@ -0,0 +1,27 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [data + [format + [binary (#+ Writer)]]]]] + ["." /// #_ + [constant (#+ Value)] + ["#." index (#+ Index)] + [encoding + ["#." unsigned (#+ U2 U4)]]]) + +(type: #export (Constant a) + (Index (Value a))) + +(def: #export equivalence + (All [a] (Equivalence (Constant a))) + ///index.equivalence) + +(def: #export length + ///index.length) + +(def: #export writer + (All [a] (Writer (Constant a))) + ///index.writer) diff --git a/stdlib/source/library/lux/target/jvm/bytecode.lux b/stdlib/source/library/lux/target/jvm/bytecode.lux new file mode 100644 index 000000000..c50278c28 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/bytecode.lux @@ -0,0 +1,1046 @@ +(.module: + [library + [lux (#- Type int try) + ["." ffi (#+ import:)] + [abstract + [monoid (#+ Monoid)] + ["." monad (#+ Monad do)]] + [control + ["." writer (#+ Writer)] + ["." state (#+ State')] + ["." function] + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." maybe] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." dictionary (#+ Dictionary)] + ["." row (#+ Row)]]] + [macro + ["." template]] + [math + [number + ["n" nat] + ["i" int] + ["." i32 (#+ I32)]]]]] + ["." / #_ + ["#." address (#+ Address)] + ["#." jump (#+ Jump Big_Jump)] + ["_" instruction (#+ Primitive_Array_Type Instruction Estimator) ("#\." monoid)] + ["#." environment (#+ Environment) + [limit + ["/." registry (#+ Register Registry)] + ["/." stack (#+ Stack)]]] + ["/#" // #_ + ["#." index (#+ Index)] + [encoding + ["#." name] + ["#." unsigned (#+ U1 U2)] + ["#." signed (#+ S1 S2 S4)]] + ["#." constant (#+ UTF8) + ["#/." pool (#+ Pool Resource)]] + [attribute + [code + ["#." exception (#+ Exception)]]] + ["." type (#+ Type) + [category (#+ Class Object Value' Value Return' Return Method)] + ["." reflection] + ["." parser]]]]) + +(type: #export Label Nat) + +(type: #export Resolver (Dictionary Label [Stack (Maybe Address)])) + +(type: #export Tracker + {#program_counter Address + #next Label + #known Resolver}) + +(def: fresh + Tracker + {#program_counter /address.start + #next 0 + #known (dictionary.new n.hash)}) + +(type: #export Relative + (-> Resolver (Try [(Row Exception) Instruction]))) + +(def: no_exceptions + (Row Exception) + row.empty) + +(def: relative_identity + Relative + (function.constant (#try.Success [..no_exceptions _.empty]))) + +(implementation: relative_monoid + (Monoid Relative) + + (def: identity ..relative_identity) + + (def: (compose left right) + (cond (is? ..relative_identity left) + right + + (is? ..relative_identity right) + left + + ## else + (function (_ resolver) + (do try.monad + [[left_exceptions left_instruction] (left resolver) + [right_exceptions right_instruction] (right resolver)] + (wrap [(\ row.monoid compose left_exceptions right_exceptions) + (_\compose left_instruction right_instruction)])))))) + +(type: #export (Bytecode a) + (State' Try [Pool Environment Tracker] (Writer Relative a))) + +(def: #export new_label + (Bytecode Label) + (function (_ [pool environment tracker]) + (#try.Success [[pool + environment + (update@ #next inc tracker)] + [..relative_identity + (get@ #next tracker)]]))) + +(exception: #export (label_has_already_been_set {label Label}) + (exception.report + ["Label" (%.nat label)])) + +(exception: #export (mismatched_environments {instruction Name} + {label Label} + {address Address} + {expected Stack} + {actual Stack}) + (exception.report + ["Instruction" (%.name instruction)] + ["Label" (%.nat label)] + ["Address" (/address.format address)] + ["Expected" (/stack.format expected)] + ["Actual" (/stack.format actual)])) + +(with_expansions [<success> (as_is (wrap [[pool + environment + (update@ #known + (dictionary.put label [actual (#.Some @here)]) + tracker)] + [..relative_identity + []]]))] + (def: #export (set_label label) + (-> Label (Bytecode Any)) + (function (_ [pool environment tracker]) + (let [@here (get@ #program_counter tracker)] + (case (dictionary.get label (get@ #known tracker)) + (#.Some [expected (#.Some address)]) + (exception.throw ..label_has_already_been_set [label]) + + (#.Some [expected #.None]) + (do try.monad + [[actual environment] (/environment.continue expected environment)] + <success>) + + #.None + (do try.monad + [[actual environment] (/environment.continue (|> environment + (get@ #/environment.stack) + (maybe.default /stack.empty)) + environment)] + <success>)))))) + +(def: #export monad + (Monad Bytecode) + (<| (:as (Monad Bytecode)) + (writer.with ..relative_monoid) + (: (Monad (State' Try [Pool Environment Tracker]))) + state.with + (: (Monad Try)) + try.monad)) + +(def: #export fail + (-> Text Bytecode) + (|>> #try.Failure function.constant)) + +(def: #export (throw exception value) + (All [e] (-> (exception.Exception e) e Bytecode)) + (..fail (exception.construct exception value))) + +(def: #export (resolve environment bytecode) + (All [a] (-> Environment (Bytecode a) (Resource [Environment (Row Exception) Instruction a]))) + (function (_ pool) + (do try.monad + [[[pool environment tracker] [relative output]] (bytecode [pool environment ..fresh]) + [exceptions instruction] (relative (get@ #known tracker))] + (wrap [pool [environment exceptions instruction output]])))) + +(def: (step estimator counter) + (-> Estimator Address (Try Address)) + (/address.move (estimator counter) counter)) + +(def: (bytecode consumption production registry [estimator bytecode] input) + (All [a] (-> U2 U2 Registry [Estimator (-> [a] Instruction)] [a] (Bytecode Any))) + (function (_ [pool environment tracker]) + (do {! try.monad} + [environment' (|> environment + (/environment.consumes consumption) + (monad.bind ! (/environment.produces production)) + (monad.bind ! (/environment.has registry))) + program_counter' (step estimator (get@ #program_counter tracker))] + (wrap [[pool + environment' + (set@ #program_counter program_counter' tracker)] + [(function.constant (wrap [..no_exceptions (bytecode input)])) + []]])))) + +(template [<name> <frames>] + [(def: <name> U2 (|> <frames> //unsigned.u2 try.assume))] + + [$0 0] + [$1 1] + [$2 2] + [$3 3] + [$4 4] + [$5 5] + [$6 6] + ) + +(template [<name> <registry>] + [(def: <name> Registry (|> <registry> //unsigned.u2 try.assume /registry.registry))] + + [@_ 0] + [@0 1] + [@1 2] + [@2 3] + [@3 4] + [@4 5] + ) + +(template [<name> <consumption> <production> <registry> <instruction>] + [(def: #export <name> + (Bytecode Any) + (..bytecode <consumption> + <production> + <registry> + <instruction> + []))] + + [nop $0 $0 @_ _.nop] + + [aconst_null $0 $1 @_ _.aconst_null] + + [iconst_m1 $0 $1 @_ _.iconst_m1] + [iconst_0 $0 $1 @_ _.iconst_0] + [iconst_1 $0 $1 @_ _.iconst_1] + [iconst_2 $0 $1 @_ _.iconst_2] + [iconst_3 $0 $1 @_ _.iconst_3] + [iconst_4 $0 $1 @_ _.iconst_4] + [iconst_5 $0 $1 @_ _.iconst_5] + + [lconst_0 $0 $2 @_ _.lconst_0] + [lconst_1 $0 $2 @_ _.lconst_1] + + [fconst_0 $0 $1 @_ _.fconst_0] + [fconst_1 $0 $1 @_ _.fconst_1] + [fconst_2 $0 $1 @_ _.fconst_2] + + [dconst_0 $0 $2 @_ _.dconst_0] + [dconst_1 $0 $2 @_ _.dconst_1] + + [pop $1 $0 @_ _.pop] + [pop2 $2 $0 @_ _.pop2] + + [dup $1 $2 @_ _.dup] + [dup_x1 $2 $3 @_ _.dup_x1] + [dup_x2 $3 $4 @_ _.dup_x2] + [dup2 $2 $4 @_ _.dup2] + [dup2_x1 $3 $5 @_ _.dup2_x1] + [dup2_x2 $4 $6 @_ _.dup2_x2] + + [swap $2 $2 @_ _.swap] + + [iaload $2 $1 @_ _.iaload] + [laload $2 $2 @_ _.laload] + [faload $2 $1 @_ _.faload] + [daload $2 $2 @_ _.daload] + [aaload $2 $1 @_ _.aaload] + [baload $2 $1 @_ _.baload] + [caload $2 $1 @_ _.caload] + [saload $2 $1 @_ _.saload] + + [iload_0 $0 $1 @0 _.iload_0] + [iload_1 $0 $1 @1 _.iload_1] + [iload_2 $0 $1 @2 _.iload_2] + [iload_3 $0 $1 @3 _.iload_3] + + [lload_0 $0 $2 @1 _.lload_0] + [lload_1 $0 $2 @2 _.lload_1] + [lload_2 $0 $2 @3 _.lload_2] + [lload_3 $0 $2 @4 _.lload_3] + + [fload_0 $0 $1 @0 _.fload_0] + [fload_1 $0 $1 @1 _.fload_1] + [fload_2 $0 $1 @2 _.fload_2] + [fload_3 $0 $1 @3 _.fload_3] + + [dload_0 $0 $2 @1 _.dload_0] + [dload_1 $0 $2 @2 _.dload_1] + [dload_2 $0 $2 @3 _.dload_2] + [dload_3 $0 $2 @4 _.dload_3] + + [aload_0 $0 $1 @0 _.aload_0] + [aload_1 $0 $1 @1 _.aload_1] + [aload_2 $0 $1 @2 _.aload_2] + [aload_3 $0 $1 @3 _.aload_3] + + [iastore $3 $1 @_ _.iastore] + [lastore $4 $1 @_ _.lastore] + [fastore $3 $1 @_ _.fastore] + [dastore $4 $1 @_ _.dastore] + [aastore $3 $1 @_ _.aastore] + [bastore $3 $1 @_ _.bastore] + [castore $3 $1 @_ _.castore] + [sastore $3 $1 @_ _.sastore] + + [istore_0 $1 $0 @0 _.istore_0] + [istore_1 $1 $0 @1 _.istore_1] + [istore_2 $1 $0 @2 _.istore_2] + [istore_3 $1 $0 @3 _.istore_3] + + [lstore_0 $2 $0 @1 _.lstore_0] + [lstore_1 $2 $0 @2 _.lstore_1] + [lstore_2 $2 $0 @3 _.lstore_2] + [lstore_3 $2 $0 @4 _.lstore_3] + + [fstore_0 $1 $0 @0 _.fstore_0] + [fstore_1 $1 $0 @1 _.fstore_1] + [fstore_2 $1 $0 @2 _.fstore_2] + [fstore_3 $1 $0 @3 _.fstore_3] + + [dstore_0 $2 $0 @1 _.dstore_0] + [dstore_1 $2 $0 @2 _.dstore_1] + [dstore_2 $2 $0 @3 _.dstore_2] + [dstore_3 $2 $0 @4 _.dstore_3] + + [astore_0 $1 $0 @0 _.astore_0] + [astore_1 $1 $0 @1 _.astore_1] + [astore_2 $1 $0 @2 _.astore_2] + [astore_3 $1 $0 @3 _.astore_3] + + [iadd $2 $1 @_ _.iadd] + [isub $2 $1 @_ _.isub] + [imul $2 $1 @_ _.imul] + [idiv $2 $1 @_ _.idiv] + [irem $2 $1 @_ _.irem] + [ineg $1 $1 @_ _.ineg] + [iand $2 $1 @_ _.iand] + [ior $2 $1 @_ _.ior] + [ixor $2 $1 @_ _.ixor] + [ishl $2 $1 @_ _.ishl] + [ishr $2 $1 @_ _.ishr] + [iushr $2 $1 @_ _.iushr] + + [ladd $4 $2 @_ _.ladd] + [lsub $4 $2 @_ _.lsub] + [lmul $4 $2 @_ _.lmul] + [ldiv $4 $2 @_ _.ldiv] + [lrem $4 $2 @_ _.lrem] + [lneg $2 $2 @_ _.lneg] + [land $4 $2 @_ _.land] + [lor $4 $2 @_ _.lor] + [lxor $4 $2 @_ _.lxor] + [lshl $3 $2 @_ _.lshl] + [lshr $3 $2 @_ _.lshr] + [lushr $3 $2 @_ _.lushr] + + [fadd $2 $1 @_ _.fadd] + [fsub $2 $1 @_ _.fsub] + [fmul $2 $1 @_ _.fmul] + [fdiv $2 $1 @_ _.fdiv] + [frem $2 $1 @_ _.frem] + [fneg $1 $1 @_ _.fneg] + + [dadd $4 $2 @_ _.dadd] + [dsub $4 $2 @_ _.dsub] + [dmul $4 $2 @_ _.dmul] + [ddiv $4 $2 @_ _.ddiv] + [drem $4 $2 @_ _.drem] + [dneg $2 $2 @_ _.dneg] + + [l2i $2 $1 @_ _.l2i] + [l2f $2 $1 @_ _.l2f] + [l2d $2 $2 @_ _.l2d] + + [f2i $1 $1 @_ _.f2i] + [f2l $1 $2 @_ _.f2l] + [f2d $1 $2 @_ _.f2d] + + [d2i $2 $1 @_ _.d2i] + [d2l $2 $2 @_ _.d2l] + [d2f $2 $1 @_ _.d2f] + + [i2l $1 $2 @_ _.i2l] + [i2f $1 $1 @_ _.i2f] + [i2d $1 $2 @_ _.i2d] + [i2b $1 $1 @_ _.i2b] + [i2c $1 $1 @_ _.i2c] + [i2s $1 $1 @_ _.i2s] + + [lcmp $4 $1 @_ _.lcmp] + + [fcmpl $2 $1 @_ _.fcmpl] + [fcmpg $2 $1 @_ _.fcmpg] + + [dcmpl $4 $1 @_ _.dcmpl] + [dcmpg $4 $1 @_ _.dcmpg] + + [arraylength $1 $1 @_ _.arraylength] + + [monitorenter $1 $0 @_ _.monitorenter] + [monitorexit $1 $0 @_ _.monitorexit] + ) + +(def: discontinuity! + (Bytecode Any) + (function (_ [pool environment tracker]) + (do try.monad + [_ (/environment.stack environment)] + (wrap [[pool + (/environment.discontinue environment) + tracker] + [..relative_identity + []]])))) + +(template [<name> <consumption> <instruction>] + [(def: #export <name> + (Bytecode Any) + (do ..monad + [_ (..bytecode <consumption> $0 @_ <instruction> [])] + ..discontinuity!))] + + [ireturn $1 _.ireturn] + [lreturn $2 _.lreturn] + [freturn $1 _.freturn] + [dreturn $2 _.dreturn] + [areturn $1 _.areturn] + [return $0 _.return] + + [athrow $1 _.athrow] + ) + +(def: #export (bipush byte) + (-> S1 (Bytecode Any)) + (..bytecode $0 $1 @_ _.bipush [byte])) + +(def: (lift resource) + (All [a] + (-> (Resource a) + (Bytecode a))) + (function (_ [pool environment tracker]) + (do try.monad + [[pool' output] (resource pool)] + (wrap [[pool' environment tracker] + [..relative_identity + output]])))) + +(def: #export (string value) + (-> //constant.UTF8 (Bytecode Any)) + (do ..monad + [index (..lift (//constant/pool.string value))] + (case (|> index //index.value //unsigned.value //unsigned.u1) + (#try.Success index) + (..bytecode $0 $1 @_ _.ldc [index]) + + (#try.Failure _) + (..bytecode $0 $1 @_ _.ldc_w/string [index])))) + +(import: java/lang/Float + ["#::." + (#static floatToRawIntBits #manual [float] int)]) + +(import: java/lang/Double + ["#::." + (#static doubleToRawLongBits #manual [double] long)]) + +(template [<name> <type> <constructor> <constant> <wide> <to_lux> <specializations>] + [(def: #export (<name> value) + (-> <type> (Bytecode Any)) + (case (|> value <to_lux>) + (^template [<special> <instruction>] + [<special> (..bytecode $0 $1 @_ <instruction> [])]) + <specializations> + + _ (do ..monad + [index (..lift (<constant> (<constructor> value)))] + (case (|> index //index.value //unsigned.value //unsigned.u1) + (#try.Success index) + (..bytecode $0 $1 @_ _.ldc [index]) + + (#try.Failure _) + (..bytecode $0 $1 @_ <wide> [index])))))] + + [int I32 //constant.integer //constant/pool.integer _.ldc_w/integer + (<| .int i32.i64) + ([-1 _.iconst_m1] + [+0 _.iconst_0] + [+1 _.iconst_1] + [+2 _.iconst_2] + [+3 _.iconst_3] + [+4 _.iconst_4] + [+5 _.iconst_5])] + ) + +(def: (arbitrary_float value) + (-> java/lang/Float (Bytecode Any)) + (do ..monad + [index (..lift (//constant/pool.float (//constant.float value)))] + (case (|> index //index.value //unsigned.value //unsigned.u1) + (#try.Success index) + (..bytecode $0 $1 @_ _.ldc [index]) + + (#try.Failure _) + (..bytecode $0 $1 @_ _.ldc_w/float [index])))) + +(def: float_bits + (-> java/lang/Float Int) + (|>> java/lang/Float::floatToRawIntBits + ffi.int_to_long + (:as Int))) + +(def: negative_zero_float_bits + (|> -0.0 (:as java/lang/Double) ffi.double_to_float ..float_bits)) + +(def: #export (float value) + (-> java/lang/Float (Bytecode Any)) + (if (i.= ..negative_zero_float_bits + (..float_bits value)) + (..arbitrary_float value) + (case (|> value ffi.float_to_double (:as Frac)) + (^template [<special> <instruction>] + [<special> (..bytecode $0 $1 @_ <instruction> [])]) + ([+0.0 _.fconst_0] + [+1.0 _.fconst_1] + [+2.0 _.fconst_2]) + + _ (..arbitrary_float value)))) + +(template [<name> <type> <constructor> <constant> <wide> <to_lux> <specializations>] + [(def: #export (<name> value) + (-> <type> (Bytecode Any)) + (case (|> value <to_lux>) + (^template [<special> <instruction>] + [<special> (..bytecode $0 $2 @_ <instruction> [])]) + <specializations> + + _ (do ..monad + [index (..lift (<constant> (<constructor> value)))] + (..bytecode $0 $2 @_ <wide> [index]))))] + + [long Int //constant.long //constant/pool.long _.ldc2_w/long + (<|) + ([+0 _.lconst_0] + [+1 _.lconst_1])] + ) + +(def: (arbitrary_double value) + (-> java/lang/Double (Bytecode Any)) + (do ..monad + [index (..lift (//constant/pool.double (//constant.double (:as Frac value))))] + (..bytecode $0 $2 @_ _.ldc2_w/double [index]))) + +(def: double_bits + (-> java/lang/Double Int) + (|>> java/lang/Double::doubleToRawLongBits + (:as Int))) + +(def: negative_zero_double_bits + (..double_bits (:as java/lang/Double -0.0))) + +(def: #export (double value) + (-> java/lang/Double (Bytecode Any)) + (if (i.= ..negative_zero_double_bits + (..double_bits value)) + (..arbitrary_double value) + (case (:as Frac value) + (^template [<special> <instruction>] + [<special> (..bytecode $0 $2 @_ <instruction> [])]) + ([+0.0 _.dconst_0] + [+1.0 _.dconst_1]) + + _ (..arbitrary_double value)))) + +(exception: #export (invalid_register {id Nat}) + (exception.report + ["ID" (%.nat id)])) + +(def: (register id) + (-> Nat (Bytecode Register)) + (case (//unsigned.u1 id) + (#try.Success register) + (\ ..monad wrap register) + + (#try.Failure error) + (..throw ..invalid_register [id]))) + +(template [<for> <size> <name> <general> <specials>] + [(def: #export (<name> local) + (-> Nat (Bytecode Any)) + (with_expansions [<specials>' (template.splice <specials>)] + (`` (case local + (~~ (template [<case> <instruction> <registry>] + [<case> (..bytecode $0 <size> <registry> <instruction> [])] + + <specials>')) + _ (do ..monad + [local (..register local)] + (..bytecode $0 <size> (<for> local) <general> [local]))))))] + + [/registry.for $1 iload _.iload + [[0 _.iload_0 @0] + [1 _.iload_1 @1] + [2 _.iload_2 @2] + [3 _.iload_3 @3]]] + [/registry.for_wide $2 lload _.lload + [[0 _.lload_0 @1] + [1 _.lload_1 @2] + [2 _.lload_2 @3] + [3 _.lload_3 @4]]] + [/registry.for $1 fload _.fload + [[0 _.fload_0 @0] + [1 _.fload_1 @1] + [2 _.fload_2 @2] + [3 _.fload_3 @3]]] + [/registry.for_wide $2 dload _.dload + [[0 _.dload_0 @1] + [1 _.dload_1 @2] + [2 _.dload_2 @3] + [3 _.dload_3 @4]]] + [/registry.for $1 aload _.aload + [[0 _.aload_0 @0] + [1 _.aload_1 @1] + [2 _.aload_2 @2] + [3 _.aload_3 @3]]] + ) + +(template [<for> <size> <name> <general> <specials>] + [(def: #export (<name> local) + (-> Nat (Bytecode Any)) + (with_expansions [<specials>' (template.splice <specials>)] + (`` (case local + (~~ (template [<case> <instruction> <registry>] + [<case> (..bytecode <size> $0 <registry> <instruction> [])] + + <specials>')) + _ (do ..monad + [local (..register local)] + (..bytecode <size> $0 (<for> local) <general> [local]))))))] + + [/registry.for $1 istore _.istore + [[0 _.istore_0 @0] + [1 _.istore_1 @1] + [2 _.istore_2 @2] + [3 _.istore_3 @3]]] + [/registry.for_wide $2 lstore _.lstore + [[0 _.lstore_0 @1] + [1 _.lstore_1 @2] + [2 _.lstore_2 @3] + [3 _.lstore_3 @4]]] + [/registry.for $1 fstore _.fstore + [[0 _.fstore_0 @0] + [1 _.fstore_1 @1] + [2 _.fstore_2 @2] + [3 _.fstore_3 @3]]] + [/registry.for_wide $2 dstore _.dstore + [[0 _.dstore_0 @1] + [1 _.dstore_1 @2] + [2 _.dstore_2 @3] + [3 _.dstore_3 @4]]] + [/registry.for $1 astore _.astore + [[0 _.astore_0 @0] + [1 _.astore_1 @1] + [2 _.astore_2 @2] + [3 _.astore_3 @3]]] + ) + +(template [<consumption> <production> <name> <instruction> <input>] + [(def: #export <name> + (-> <input> (Bytecode Any)) + (..bytecode <consumption> <production> @_ <instruction>))] + + [$1 $1 newarray _.newarray Primitive_Array_Type] + [$0 $1 sipush _.sipush S2] + ) + +(exception: #export (unknown_label {label Label}) + (exception.report + ["Label" (%.nat label)])) + +(exception: #export (cannot_do_a_big_jump {label Label} + {@from Address} + {jump Big_Jump}) + (exception.report + ["Label" (%.nat label)] + ["Start" (|> @from /address.value //unsigned.value %.nat)] + ["Target" (|> jump //signed.value %.int)])) + +(type: Any_Jump (Either Big_Jump Jump)) + +(def: (jump @from @to) + (-> Address Address (Try Any_Jump)) + (do {! try.monad} + [jump (\ ! map //signed.value + (/address.jump @from @to))] + (let [big? (n.> (//unsigned.value //unsigned.maximum/2) + (.nat (i.* (if (i.>= +0 jump) + +1 + -1) + jump)))] + (if big? + (\ ! map (|>> #.Left) (//signed.s4 jump)) + (\ ! map (|>> #.Right) (//signed.s2 jump)))))) + +(exception: #export (unset_label {label Label}) + (exception.report + ["Label" (%.nat label)])) + +(def: (resolve_label label resolver) + (-> Label Resolver (Try [Stack Address])) + (case (dictionary.get label resolver) + (#.Some [actual (#.Some address)]) + (#try.Success [actual address]) + + (#.Some [actual #.None]) + (exception.throw ..unset_label [label]) + + #.None + (exception.throw ..unknown_label [label]))) + +(def: (acknowledge_label stack label tracker) + (-> Stack Label Tracker Tracker) + (case (dictionary.get label (get@ #known tracker)) + (#.Some _) + tracker + + #.None + (update@ #known (dictionary.put label [stack #.None]) tracker))) + +(template [<consumption> <name> <instruction>] + [(def: #export (<name> label) + (-> Label (Bytecode Any)) + (let [[estimator bytecode] <instruction>] + (function (_ [pool environment tracker]) + (let [@here (get@ #program_counter tracker)] + (do try.monad + [environment' (|> environment + (/environment.consumes <consumption>)) + actual (/environment.stack environment') + program_counter' (step estimator @here)] + (wrap (let [@from @here] + [[pool + environment' + (|> tracker + (..acknowledge_label actual label) + (set@ #program_counter program_counter'))] + [(function (_ resolver) + (do try.monad + [[expected @to] (..resolve_label label resolver) + _ (exception.assert ..mismatched_environments [(name_of <instruction>) label @here expected actual] + (\ /stack.equivalence = expected actual)) + jump (..jump @from @to)] + (case jump + (#.Left jump) + (exception.throw ..cannot_do_a_big_jump [label @from jump]) + + (#.Right jump) + (wrap [..no_exceptions (bytecode jump)])))) + []]])))))))] + + [$1 ifeq _.ifeq] + [$1 ifne _.ifne] + [$1 iflt _.iflt] + [$1 ifge _.ifge] + [$1 ifgt _.ifgt] + [$1 ifle _.ifle] + + [$1 ifnull _.ifnull] + [$1 ifnonnull _.ifnonnull] + + [$2 if_icmpeq _.if_icmpeq] + [$2 if_icmpne _.if_icmpne] + [$2 if_icmplt _.if_icmplt] + [$2 if_icmpge _.if_icmpge] + [$2 if_icmpgt _.if_icmpgt] + [$2 if_icmple _.if_icmple] + + [$2 if_acmpeq _.if_acmpeq] + [$2 if_acmpne _.if_acmpne] + ) + +(template [<name> <instruction> <on_long_jump> <on_short_jump>] + [(def: #export (<name> label) + (-> Label (Bytecode Any)) + (let [[estimator bytecode] <instruction>] + (function (_ [pool environment tracker]) + (do try.monad + [actual (/environment.stack environment) + #let [@here (get@ #program_counter tracker)] + program_counter' (step estimator @here)] + (wrap (let [@from @here] + [[pool + (/environment.discontinue environment) + (|> tracker + (..acknowledge_label actual label) + (set@ #program_counter program_counter'))] + [(function (_ resolver) + (case (dictionary.get label resolver) + (#.Some [expected (#.Some @to)]) + (do try.monad + [_ (exception.assert ..mismatched_environments [(name_of <instruction>) label @here expected actual] + (\ /stack.equivalence = expected actual)) + jump (..jump @from @to)] + (case jump + (#.Left jump) + <on_long_jump> + + (#.Right jump) + <on_short_jump>)) + + (#.Some [expected #.None]) + (exception.throw ..unset_label [label]) + + #.None + (exception.throw ..unknown_label [label]))) + []]]))))))] + + [goto _.goto + (exception.throw ..cannot_do_a_big_jump [label @from jump]) + (wrap [..no_exceptions (bytecode jump)])] + [goto_w _.goto_w + (wrap [..no_exceptions (bytecode jump)]) + (wrap [..no_exceptions (bytecode (/jump.lift jump))])] + ) + +(def: (big_jump jump) + (-> Any_Jump Big_Jump) + (case jump + (#.Left big) + big + + (#.Right small) + (/jump.lift small))) + +(exception: #export invalid_tableswitch) + +(def: #export (tableswitch minimum default [at_minimum afterwards]) + (-> S4 Label [Label (List Label)] (Bytecode Any)) + (let [[estimator bytecode] _.tableswitch] + (function (_ [pool environment tracker]) + (do try.monad + [environment' (|> environment + (/environment.consumes $1)) + actual (/environment.stack environment') + program_counter' (step (estimator (list.size afterwards)) (get@ #program_counter tracker))] + (wrap (let [@from (get@ #program_counter tracker)] + [[pool + environment' + (|> (list\fold (..acknowledge_label actual) tracker (list& default at_minimum afterwards)) + (set@ #program_counter program_counter'))] + [(function (_ resolver) + (let [get (: (-> Label (Maybe [Stack (Maybe Address)])) + (function (_ label) + (dictionary.get label resolver)))] + (case (do {! maybe.monad} + [@default (|> default get (monad.bind ! product.right)) + @at_minimum (|> at_minimum get (monad.bind ! product.right)) + @afterwards (|> afterwards + (monad.map ! get) + (monad.bind ! (monad.map ! product.right)))] + (wrap [@default @at_minimum @afterwards])) + (#.Some [@default @at_minimum @afterwards]) + (do {! try.monad} + [>default (\ ! map ..big_jump (..jump @from @default)) + >at_minimum (\ ! map ..big_jump (..jump @from @at_minimum)) + >afterwards (monad.map ! (|>> (..jump @from) (\ ! map ..big_jump)) + @afterwards)] + (wrap [..no_exceptions (bytecode minimum >default [>at_minimum >afterwards])])) + + #.None + (exception.throw ..invalid_tableswitch [])))) + []]])))))) + +(exception: #export invalid_lookupswitch) + +(def: #export (lookupswitch default cases) + (-> Label (List [S4 Label]) (Bytecode Any)) + (let [cases (list.sort (function (_ [left _] [right _]) + (i.< (//signed.value left) + (//signed.value right))) + cases) + [estimator bytecode] _.lookupswitch] + (function (_ [pool environment tracker]) + (do try.monad + [environment' (|> environment + (/environment.consumes $1)) + actual (/environment.stack environment') + program_counter' (step (estimator (list.size cases)) (get@ #program_counter tracker))] + (wrap (let [@from (get@ #program_counter tracker)] + [[pool + environment' + (|> (list\fold (..acknowledge_label actual) tracker (list& default (list\map product.right cases))) + (set@ #program_counter program_counter'))] + [(function (_ resolver) + (let [get (: (-> Label (Maybe [Stack (Maybe Address)])) + (function (_ label) + (dictionary.get label resolver)))] + (case (do {! maybe.monad} + [@default (|> default get (monad.bind ! product.right)) + @cases (|> cases + (monad.map ! (|>> product.right get)) + (monad.bind ! (monad.map ! product.right)))] + (wrap [@default @cases])) + (#.Some [@default @cases]) + (do {! try.monad} + [>default (\ ! map ..big_jump (..jump @from @default)) + >cases (|> @cases + (monad.map ! (|>> (..jump @from) (\ ! map ..big_jump))) + (\ ! map (|>> (list.zip/2 (list\map product.left cases)))))] + (wrap [..no_exceptions (bytecode >default >cases)])) + + #.None + (exception.throw ..invalid_lookupswitch [])))) + []]])))))) + +(def: reflection + (All [category] + (-> (Type (<| Return' Value' category)) Text)) + (|>> type.reflection reflection.reflection)) + +(template [<consumption> <production> <name> <category> <instruction>] + [(def: #export (<name> class) + (-> (Type <category>) (Bytecode Any)) + (do ..monad + [## TODO: Make sure it's impossible to have indexes greater than U2. + index (..lift (//constant/pool.class (//name.internal (..reflection class))))] + (..bytecode <consumption> <production> @_ <instruction> [index])))] + + [$0 $1 new Class _.new] + [$1 $1 anewarray Object _.anewarray] + [$1 $1 checkcast Object _.checkcast] + [$1 $1 instanceof Object _.instanceof] + ) + +(def: #export (iinc register increase) + (-> Nat U1 (Bytecode Any)) + (do ..monad + [register (..register register)] + (..bytecode $0 $0 (/registry.for register) _.iinc [register increase]))) + +(exception: #export (multiarray_cannot_be_zero_dimensional {class (Type Object)}) + (exception.report ["Class" (..reflection class)])) + +(def: #export (multianewarray class dimensions) + (-> (Type Object) U1 (Bytecode Any)) + (do ..monad + [_ (: (Bytecode Any) + (case (|> dimensions //unsigned.value) + 0 (..throw ..multiarray_cannot_be_zero_dimensional [class]) + _ (wrap []))) + index (..lift (//constant/pool.class (//name.internal (..reflection class))))] + (..bytecode (//unsigned.lift/2 dimensions) $1 @_ _.multianewarray [index dimensions]))) + +(def: (type_size type) + (-> (Type Return) Nat) + (cond (is? type.void type) + 0 + + (or (is? type.long type) + (is? type.double type)) + 2 + + ## else + 1)) + +(template [<static?> <name> <instruction> <method>] + [(def: #export (<name> class method type) + (-> (Type Class) Text (Type Method) (Bytecode Any)) + (let [[inputs output exceptions] (parser.method type)] + (do ..monad + [index (<| ..lift + (<method> (..reflection class)) + {#//constant/pool.name method + #//constant/pool.descriptor (type.descriptor type)}) + #let [consumption (|> inputs + (list\map ..type_size) + (list\fold n.+ (if <static?> 0 1)) + //unsigned.u1 + try.assume) + production (|> output ..type_size //unsigned.u1 try.assume)]] + (..bytecode (//unsigned.lift/2 consumption) + (//unsigned.lift/2 production) + @_ + <instruction> [index consumption production]))))] + + [#1 invokestatic _.invokestatic //constant/pool.method] + [#0 invokevirtual _.invokevirtual //constant/pool.method] + [#0 invokespecial _.invokespecial //constant/pool.method] + [#0 invokeinterface _.invokeinterface //constant/pool.interface_method] + ) + +(template [<consumption> <name> <1> <2>] + [(def: #export (<name> class field type) + (-> (Type Class) Text (Type Value) (Bytecode Any)) + (do ..monad + [index (<| ..lift + (//constant/pool.field (..reflection class)) + {#//constant/pool.name field + #//constant/pool.descriptor (type.descriptor type)})] + (if (or (is? type.long type) + (is? type.double type)) + (..bytecode <consumption> $2 @_ <2> [index]) + (..bytecode <consumption> $1 @_ <1> [index]))))] + + [$0 getstatic _.getstatic/1 _.getstatic/2] + [$1 putstatic _.putstatic/1 _.putstatic/2] + [$1 getfield _.getfield/1 _.getfield/2] + [$2 putfield _.putfield/1 _.putfield/2] + ) + +(exception: #export (invalid_range_for_try {start Address} {end Address}) + (exception.report + ["Start" (|> start /address.value //unsigned.value %.nat)] + ["End" (|> end /address.value //unsigned.value %.nat)])) + +(def: #export (try @start @end @handler catch) + (-> Label Label Label (Type Class) (Bytecode Any)) + (do ..monad + [@catch (..lift (//constant/pool.class (//name.internal (..reflection catch))))] + (function (_ [pool environment tracker]) + (#try.Success + [[pool + environment + (..acknowledge_label /stack.catch @handler tracker)] + [(function (_ resolver) + (do try.monad + [[_ @start] (..resolve_label @start resolver) + [_ @end] (..resolve_label @end resolver) + _ (if (/address.after? @start @end) + (wrap []) + (exception.throw ..invalid_range_for_try [@start @end])) + [_ @handler] (..resolve_label @handler resolver)] + (wrap [(row.row {#//exception.start @start + #//exception.end @end + #//exception.handler @handler + #//exception.catch @catch}) + _.empty]))) + []]])))) + +(def: #export (compose pre post) + (All [pre post] + (-> (Bytecode pre) (Bytecode post) (Bytecode post))) + (do ..monad + [_ pre] + post)) diff --git a/stdlib/source/library/lux/target/jvm/bytecode/address.lux b/stdlib/source/library/lux/target/jvm/bytecode/address.lux new file mode 100644 index 000000000..8d51a8597 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/bytecode/address.lux @@ -0,0 +1,74 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ do)]] + [control + ["." try (#+ Try)]] + [data + [format + [binary (#+ Writer)]] + [text + ["%" format (#+ Format)]]] + [math + [number + ["n" nat]]] + [type + abstract]]] + ["." // #_ + [jump (#+ Big_Jump)] + ["/#" // #_ + [encoding + ["#." unsigned (#+ U2)] + ["#." signed (#+ S4)]]]]) + +(abstract: #export Address + U2 + + (def: #export value + (-> Address U2) + (|>> :representation)) + + (def: #export start + Address + (|> 0 ///unsigned.u2 try.assume :abstraction)) + + (def: #export (move distance) + (-> U2 (-> Address (Try Address))) + (|>> :representation + (///unsigned.+/2 distance) + (\ try.functor map (|>> :abstraction)))) + + (def: with_sign + (-> Address (Try S4)) + (|>> :representation ///unsigned.value .int ///signed.s4)) + + (def: #export (jump from to) + (-> Address Address (Try Big_Jump)) + (do try.monad + [from (with_sign from) + to (with_sign to)] + (///signed.-/4 from to))) + + (def: #export (after? reference subject) + (-> Address Address Bit) + (n.> (|> reference :representation ///unsigned.value) + (|> subject :representation ///unsigned.value))) + + (implementation: #export equivalence + (Equivalence Address) + + (def: (= reference subject) + (\ ///unsigned.equivalence = + (:representation reference) + (:representation subject)))) + + (def: #export writer + (Writer Address) + (|>> :representation ///unsigned.writer/2)) + + (def: #export format + (Format Address) + (|>> :representation ///unsigned.value %.nat)) + ) diff --git a/stdlib/source/library/lux/target/jvm/bytecode/environment.lux b/stdlib/source/library/lux/target/jvm/bytecode/environment.lux new file mode 100644 index 000000000..fdf50d974 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/bytecode/environment.lux @@ -0,0 +1,108 @@ +(.module: + [library + [lux (#- Type static) + [abstract + [monad (#+ do)] + [monoid (#+ Monoid)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]]]] + [/ + ["/." limit (#+ Limit) + ["/." stack (#+ Stack)] + ["/." registry (#+ Registry)]] + [/// + [encoding + [unsigned (#+ U2)]] + [type (#+ Type) + [category (#+ Method)]]]]) + +(type: #export Environment + {#limit Limit + #stack (Maybe Stack)}) + +(template [<name> <limit>] + [(def: #export (<name> type) + (-> (Type Method) (Try Environment)) + (do try.monad + [limit (<limit> type)] + (wrap {#limit limit + #stack (#.Some /stack.empty)})))] + + [static /limit.static] + [virtual /limit.virtual] + ) + +(type: #export Condition + (-> Environment (Try Environment))) + +(implementation: #export monoid + (Monoid Condition) + + (def: identity (|>> #try.Success)) + + (def: (compose left right) + (function (_ environment) + (do try.monad + [environment (left environment)] + (right environment))))) + +(exception: #export discontinuity) + +(def: #export (stack environment) + (-> Environment (Try Stack)) + (case (get@ #..stack environment) + (#.Some stack) + (#try.Success stack) + + #.None + (exception.throw ..discontinuity []))) + +(def: #export discontinue + (-> Environment Environment) + (set@ #..stack #.None)) + +(exception: #export (mismatched_stacks {expected Stack} + {actual Stack}) + (exception.report + ["Expected" (/stack.format expected)] + ["Actual" (/stack.format actual)])) + +(def: #export (continue expected environment) + (-> Stack Environment (Try [Stack Environment])) + (case (get@ #..stack environment) + (#.Some actual) + (if (\ /stack.equivalence = expected actual) + (#try.Success [actual environment]) + (exception.throw ..mismatched_stacks [expected actual])) + + #.None + (#try.Success [expected (set@ #..stack (#.Some expected) environment)]))) + +(def: #export (consumes amount) + (-> U2 Condition) + ## TODO: Revisit this definition once lenses/optics have been implemented, + ## since it can probably be simplified with them. + (function (_ environment) + (do try.monad + [previous (..stack environment) + current (/stack.pop amount previous)] + (wrap (set@ #..stack (#.Some current) environment))))) + +(def: #export (produces amount) + (-> U2 Condition) + (function (_ environment) + (do try.monad + [previous (..stack environment) + current (/stack.push amount previous) + #let [limit (|> environment + (get@ [#..limit #/limit.stack]) + (/stack.max current))]] + (wrap (|> environment + (set@ #..stack (#.Some current)) + (set@ [#..limit #/limit.stack] limit)))))) + +(def: #export (has registry) + (-> Registry Condition) + (|>> (update@ [#..limit #/limit.registry] (/registry.has registry)) + #try.Success)) diff --git a/stdlib/source/library/lux/target/jvm/bytecode/environment/limit.lux b/stdlib/source/library/lux/target/jvm/bytecode/environment/limit.lux new file mode 100644 index 000000000..c7e9a8959 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/bytecode/environment/limit.lux @@ -0,0 +1,58 @@ +(.module: + [library + [lux (#- Type static) + [abstract + [monad (#+ do)] + [equivalence (#+ Equivalence)]] + [control + ["." try (#+ Try)]] + [data + ["." product] + ["." format #_ + ["#" binary (#+ Writer) ("#\." monoid)]]] + [math + [number + ["n" nat]]]]] + ["." / #_ + ["#." stack (#+ Stack)] + ["#." registry (#+ Registry)] + [//// + [type (#+ Type) + [category (#+ Method)]]]]) + +(type: #export Limit + {#stack Stack + #registry Registry}) + +(template [<name> <registry>] + [(def: #export (<name> type) + (-> (Type Method) (Try Limit)) + (do try.monad + [registry (<registry> type)] + (wrap {#stack /stack.empty + #registry registry})))] + + [static /registry.static] + [virtual /registry.virtual] + ) + +(def: #export length + ($_ n.+ + ## u2 max_stack; + /stack.length + ## u2 max_locals; + /registry.length)) + +(def: #export equivalence + (Equivalence Limit) + ($_ product.equivalence + /stack.equivalence + /registry.equivalence + )) + +(def: #export (writer limit) + (Writer Limit) + ($_ format\compose + (/stack.writer (get@ #stack limit)) + (/registry.writer (get@ #registry limit)) + )) diff --git a/stdlib/source/library/lux/target/jvm/bytecode/environment/limit/registry.lux b/stdlib/source/library/lux/target/jvm/bytecode/environment/limit/registry.lux new file mode 100644 index 000000000..05872be60 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/bytecode/environment/limit/registry.lux @@ -0,0 +1,91 @@ +(.module: + [library + [lux (#- Type for static) + [abstract + ["." equivalence (#+ Equivalence)]] + [control + ["." try (#+ Try) ("#\." functor)]] + [data + [format + [binary (#+ Writer)]] + [collection + ["." list ("#\." functor fold)]]] + [math + [number + ["n" nat]]] + [type + abstract]]] + ["." ///// #_ + [encoding + ["#." unsigned (#+ U1 U2)]] + ["#." type (#+ Type) + [category (#+ Method)] + ["#/." parser]]]) + +(type: #export Register U1) + +(def: normal 1) +(def: wide 2) + +(abstract: #export Registry + U2 + + (def: #export registry + (-> U2 Registry) + (|>> :abstraction)) + + (def: (minimal type) + (-> (Type Method) Nat) + (let [[inputs output exceptions] (/////type/parser.method type)] + (|> inputs + (list\map (function (_ input) + (if (or (is? /////type.long input) + (is? /////type.double input)) + ..wide + ..normal))) + (list\fold n.+ 0)))) + + (template [<start> <name>] + [(def: #export <name> + (-> (Type Method) (Try Registry)) + (|>> ..minimal + (n.+ <start>) + /////unsigned.u2 + (try\map ..registry)))] + + [0 static] + [1 virtual] + ) + + (def: #export equivalence + (Equivalence Registry) + (\ equivalence.functor map + (|>> :representation) + /////unsigned.equivalence)) + + (def: #export writer + (Writer Registry) + (|>> :representation /////unsigned.writer/2)) + + (def: #export (has needed) + (-> Registry Registry Registry) + (|>> :representation + (/////unsigned.max/2 (:representation needed)) + :abstraction)) + + (template [<name> <extra>] + [(def: #export <name> + (-> Register Registry) + (let [extra (|> <extra> /////unsigned.u2 try.assume)] + (|>> /////unsigned.lift/2 + (/////unsigned.+/2 extra) + try.assume + :abstraction)))] + + [for ..normal] + [for_wide ..wide] + ) + ) + +(def: #export length + /////unsigned.bytes/2) diff --git a/stdlib/source/library/lux/target/jvm/bytecode/environment/limit/stack.lux b/stdlib/source/library/lux/target/jvm/bytecode/environment/limit/stack.lux new file mode 100644 index 000000000..99a560347 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/bytecode/environment/limit/stack.lux @@ -0,0 +1,69 @@ +(.module: + [library + [lux #* + [abstract + ["." equivalence (#+ Equivalence)]] + [control + ["." try (#+ Try)]] + [data + ["." maybe] + [text + ["%" format (#+ Format)]] + [format + [binary (#+ Writer)]]] + [type + abstract]]] + ["." ///// #_ + [encoding + ["#." unsigned (#+ U2)]]]) + +(abstract: #export Stack + U2 + + (template [<frames> <name>] + [(def: #export <name> + Stack + (|> <frames> /////unsigned.u2 maybe.assume :abstraction))] + + [0 empty] + [1 catch] + ) + + (def: #export equivalence + (Equivalence Stack) + (\ equivalence.functor map + (|>> :representation) + /////unsigned.equivalence)) + + (def: #export writer + (Writer Stack) + (|>> :representation /////unsigned.writer/2)) + + (def: stack + (-> U2 Stack) + (|>> :abstraction)) + + (template [<op> <name>] + [(def: #export (<name> amount) + (-> U2 (-> Stack (Try Stack))) + (|>> :representation + (<op> amount) + (\ try.functor map ..stack)))] + + [/////unsigned.+/2 push] + [/////unsigned.-/2 pop] + ) + + (def: #export (max left right) + (-> Stack Stack Stack) + (:abstraction + (/////unsigned.max/2 (:representation left) + (:representation right)))) + + (def: #export format + (Format Stack) + (|>> :representation /////unsigned.value %.nat)) + ) + +(def: #export length + /////unsigned.bytes/2) diff --git a/stdlib/source/library/lux/target/jvm/bytecode/instruction.lux b/stdlib/source/library/lux/target/jvm/bytecode/instruction.lux new file mode 100644 index 000000000..65e36875f --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/bytecode/instruction.lux @@ -0,0 +1,714 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)] + [monoid (#+ Monoid)]] + [control + ["." function] + ["." try]] + [data + ["." product] + ["." binary] + ["." format #_ + ["#" binary (#+ Mutation Specification)]] + [collection + ["." list]]] + [macro + ["." template]] + [math + [number (#+ hex) + ["n" nat]]] + [type + abstract]]] + ["." // #_ + ["#." address (#+ Address)] + ["#." jump (#+ Jump Big_Jump)] + [environment + [limit + [registry (#+ Register)]]] + ["/#" // #_ + ["#." index (#+ Index)] + ["#." constant (#+ Class Reference)] + [encoding + ["#." unsigned (#+ U1 U2 U4)] + ["#." signed (#+ S1 S2 S4)]] + [type + [category (#+ Value Method)]]]]) + +(type: #export Size U2) + +(type: #export Estimator + (-> Address Size)) + +(def: fixed + (-> Size Estimator) + function.constant) + +(type: #export Instruction + (-> Specification Specification)) + +(def: #export empty + Instruction + function.identity) + +(def: #export run + (-> Instruction Specification) + (function.apply format.no_op)) + +(type: Opcode Nat) + +(template [<name> <size>] + [(def: <name> Size (|> <size> ///unsigned.u2 try.assume))] + + [opcode_size 1] + [register_size 1] + [byte_size 1] + [index_size 2] + [big_jump_size 4] + [integer_size 4] + ) + +(def: (nullary' opcode) + (-> Opcode Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value ..opcode_size) + offset) + (try.assume + (binary.write/8 offset opcode binary))])) + +(def: nullary + [Estimator (-> Opcode Instruction)] + [(..fixed ..opcode_size) + (function (_ opcode [size mutation]) + [(n.+ (///unsigned.value ..opcode_size) + size) + (|>> mutation ((nullary' opcode)))])]) + +(template [<name> <size>] + [(def: <name> + Size + (|> ..opcode_size + (///unsigned.+/2 <size>) try.assume))] + + [size/1 ..register_size] + [size/2 ..index_size] + [size/4 ..big_jump_size] + ) + +(template [<shift> <name> <inputT> <writer> <unwrap>] + [(with_expansions [<private> (template.identifier ["'" <name>])] + (def: (<private> opcode input0) + (-> Opcode <inputT> Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value <shift>) offset) + (try.assume + (do try.monad + [_ (binary.write/8 offset opcode binary)] + (<writer> (n.+ (///unsigned.value ..opcode_size) offset) + (<unwrap> input0) + binary)))])) + + (def: <name> + [Estimator (-> Opcode <inputT> Instruction)] + [(..fixed <shift>) + (function (_ opcode input0 [size mutation]) + [(n.+ (///unsigned.value <shift>) size) + (|>> mutation ((<private> opcode input0)))])]))] + + [..size/1 unary/1 U1 binary.write/8 ///unsigned.value] + [..size/2 unary/2 U2 binary.write/16 ///unsigned.value] + [..size/2 jump/2 Jump binary.write/16 ///signed.value] + [..size/4 jump/4 Big_Jump binary.write/32 ///signed.value] + ) + +(template [<shift> <name> <inputT> <writer>] + [(with_expansions [<private> (template.identifier ["'" <name>])] + (def: (<private> opcode input0) + (-> Opcode <inputT> Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value <shift>) offset) + (try.assume + (do try.monad + [_ (binary.write/8 offset opcode binary)] + (<writer> (n.+ (///unsigned.value ..opcode_size) offset) + (///signed.value input0) + binary)))])) + + (def: <name> + [Estimator (-> Opcode <inputT> Instruction)] + [(..fixed <shift>) + (function (_ opcode input0 [size mutation]) + [(n.+ (///unsigned.value <shift>) size) + (|>> mutation ((<private> opcode input0)))])]))] + + [..size/1 unary/1' S1 binary.write/8] + [..size/2 unary/2' S2 binary.write/16] + ) + +(def: size/11 + Size + (|> ..opcode_size + (///unsigned.+/2 ..register_size) try.assume + (///unsigned.+/2 ..byte_size) try.assume)) + +(def: (binary/11' opcode input0 input1) + (-> Opcode U1 U1 Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value ..size/11) offset) + (try.assume + (do try.monad + [_ (binary.write/8 offset opcode binary) + _ (binary.write/8 (n.+ (///unsigned.value ..opcode_size) offset) + (///unsigned.value input0) + binary)] + (binary.write/8 (n.+ (///unsigned.value ..size/1) offset) + (///unsigned.value input1) + binary)))])) + +(def: binary/11 + [Estimator (-> Opcode U1 U1 Instruction)] + [(..fixed ..size/11) + (function (_ opcode input0 input1 [size mutation]) + [(n.+ (///unsigned.value ..size/11) size) + (|>> mutation ((binary/11' opcode input0 input1)))])]) + +(def: size/21 + Size + (|> ..opcode_size + (///unsigned.+/2 ..index_size) try.assume + (///unsigned.+/2 ..byte_size) try.assume)) + +(def: (binary/21' opcode input0 input1) + (-> Opcode U2 U1 Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value ..size/21) offset) + (try.assume + (do try.monad + [_ (binary.write/8 offset opcode binary) + _ (binary.write/16 (n.+ (///unsigned.value ..opcode_size) offset) + (///unsigned.value input0) + binary)] + (binary.write/8 (n.+ (///unsigned.value ..size/2) offset) + (///unsigned.value input1) + binary)))])) + +(def: binary/21 + [Estimator (-> Opcode U2 U1 Instruction)] + [(..fixed ..size/21) + (function (_ opcode input0 input1 [size mutation]) + [(n.+ (///unsigned.value ..size/21) size) + (|>> mutation ((binary/21' opcode input0 input1)))])]) + +(def: size/211 + Size + (|> ..opcode_size + (///unsigned.+/2 ..index_size) try.assume + (///unsigned.+/2 ..byte_size) try.assume + (///unsigned.+/2 ..byte_size) try.assume)) + +(def: (trinary/211' opcode input0 input1 input2) + (-> Opcode U2 U1 U1 Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value ..size/211) offset) + (try.assume + (do try.monad + [_ (binary.write/8 offset opcode binary) + _ (binary.write/16 (n.+ (///unsigned.value ..opcode_size) offset) + (///unsigned.value input0) + binary) + _ (binary.write/8 (n.+ (///unsigned.value ..size/2) offset) + (///unsigned.value input1) + binary)] + (binary.write/8 (n.+ (///unsigned.value ..size/21) offset) + (///unsigned.value input2) + binary)))])) + +(def: trinary/211 + [Estimator (-> Opcode U2 U1 U1 Instruction)] + [(..fixed ..size/211) + (function (_ opcode input0 input1 input2 [size mutation]) + [(n.+ (///unsigned.value ..size/211) size) + (|>> mutation ((trinary/211' opcode input0 input1 input2)))])]) + +(abstract: #export Primitive_Array_Type + U1 + + (def: code + (-> Primitive_Array_Type U1) + (|>> :representation)) + + (template [<code> <name>] + [(def: #export <name> (|> <code> ///unsigned.u1 try.assume :abstraction))] + + [04 t_boolean] + [05 t_char] + [06 t_float] + [07 t_double] + [08 t_byte] + [09 t_short] + [10 t_int] + [11 t_long] + )) + +## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-6.html#jvms-6.5 +(with_expansions [<constants> (template [<code> <name>] + [[<code> <name> [] []]] + + ["01" aconst_null] + + ["02" iconst_m1] + ["03" iconst_0] + ["04" iconst_1] + ["05" iconst_2] + ["06" iconst_3] + ["07" iconst_4] + ["08" iconst_5] + + ["09" lconst_0] + ["0A" lconst_1] + + ["0B" fconst_0] + ["0C" fconst_1] + ["0D" fconst_2] + + ["0E" dconst_0] + ["0F" dconst_1]) + <register_loads> (template [<code> <name>] + [[<code> <name> [[register Register]] [register]]] + + ["15" iload] + ["16" lload] + ["17" fload] + ["18" dload] + ["19" aload]) + <simple_register_loads> (template [<code> <name>] + [[<code> <name> [] []]] + + ["1A" iload_0] + ["1B" iload_1] + ["1C" iload_2] + ["1D" iload_3] + + ["1E" lload_0] + ["1F" lload_1] + ["20" lload_2] + ["21" lload_3] + + ["22" fload_0] + ["23" fload_1] + ["24" fload_2] + ["25" fload_3] + + ["26" dload_0] + ["27" dload_1] + ["28" dload_2] + ["29" dload_3] + + ["2A" aload_0] + ["2B" aload_1] + ["2C" aload_2] + ["2D" aload_3]) + <register_stores> (template [<code> <name>] + [[<code> <name> [[register Register]] [register]]] + + ["36" istore] + ["37" lstore] + ["38" fstore] + ["39" dstore] + ["3A" astore]) + <simple_register_stores> (template [<code> <name>] + [[<code> <name> [] []]] + + ["3B" istore_0] + ["3C" istore_1] + ["3D" istore_2] + ["3E" istore_3] + + ["3F" lstore_0] + ["40" lstore_1] + ["41" lstore_2] + ["42" lstore_3] + + ["43" fstore_0] + ["44" fstore_1] + ["45" fstore_2] + ["46" fstore_3] + + ["47" dstore_0] + ["48" dstore_1] + ["49" dstore_2] + ["4A" dstore_3] + + ["4B" astore_0] + ["4C" astore_1] + ["4D" astore_2] + ["4E" astore_3]) + <array_loads> (template [<code> <name>] + [[<code> <name> [] []]] + + ["2E" iaload] + ["2F" laload] + ["30" faload] + ["31" daload] + ["32" aaload] + ["33" baload] + ["34" caload] + ["35" saload]) + <array_stores> (template [<code> <name>] + [[<code> <name> [] []]] + + ["4f" iastore] + ["50" lastore] + ["51" fastore] + ["52" dastore] + ["53" aastore] + ["54" bastore] + ["55" castore] + ["56" sastore]) + <arithmetic> (template [<code> <name>] + [[<code> <name> [] []]] + + ["60" iadd] + ["64" isub] + ["68" imul] + ["6c" idiv] + ["70" irem] + ["74" ineg] + ["78" ishl] + ["7a" ishr] + ["7c" iushr] + ["7e" iand] + ["80" ior] + ["82" ixor] + + ["61" ladd] + ["65" lsub] + ["69" lmul] + ["6D" ldiv] + ["71" lrem] + ["75" lneg] + ["7F" land] + ["81" lor] + ["83" lxor] + + ["62" fadd] + ["66" fsub] + ["6A" fmul] + ["6E" fdiv] + ["72" frem] + ["76" fneg] + + ["63" dadd] + ["67" dsub] + ["6B" dmul] + ["6F" ddiv] + ["73" drem] + ["77" dneg]) + <conversions> (template [<code> <name>] + [[<code> <name> [] []]] + + ["88" l2i] + ["89" l2f] + ["8A" l2d] + + ["8B" f2i] + ["8C" f2l] + ["8D" f2d] + + ["8E" d2i] + ["8F" d2l] + ["90" d2f] + + ["85" i2l] + ["86" i2f] + ["87" i2d] + ["91" i2b] + ["92" i2c] + ["93" i2s]) + <comparisons> (template [<code> <name>] + [[<code> <name> [] []]] + + ["94" lcmp] + + ["95" fcmpl] + ["96" fcmpg] + + ["97" dcmpl] + ["98" dcmpg]) + <returns> (template [<code> <name>] + [[<code> <name> [] []]] + + ["AC" ireturn] + ["AD" lreturn] + ["AE" freturn] + ["AF" dreturn] + ["B0" areturn] + ["B1" return] + ) + <jumps> (template [<code> <name>] + [[<code> <name> [[jump Jump]] [jump]]] + + ["99" ifeq] + ["9A" ifne] + ["9B" iflt] + ["9C" ifge] + ["9D" ifgt] + ["9E" ifle] + + ["9F" if_icmpeq] + ["A0" if_icmpne] + ["A1" if_icmplt] + ["A2" if_icmpge] + ["A3" if_icmpgt] + ["A4" if_icmple] + + ["A5" if_acmpeq] + ["A6" if_acmpne] + + ["A7" goto] + ["A8" jsr] + + ["C6" ifnull] + ["C7" ifnonnull]) + <fields> (template [<code> <name>] + [[<code> <name> [[index (Index (Reference Value))]] [(///index.value index)]]] + + ["B2" getstatic/1] ["B2" getstatic/2] + ["B3" putstatic/1] ["B3" putstatic/2] + ["B4" getfield/1] ["B4" getfield/2] + ["B5" putfield/1] ["B5" putfield/2])] + (template [<arity> <definitions>] + [(with_expansions [<definitions>' (template.splice <definitions>)] + (template [<code> <name> <instruction_inputs> <arity_inputs>] + [(with_expansions [<inputs>' (template.splice <instruction_inputs>) + <input_types> (template [<input_name> <input_type>] + [<input_type>] + + <inputs>') + <input_names> (template [<input_name> <input_type>] + [<input_name>] + + <inputs>')] + (def: #export <name> + [Estimator (-> [<input_types>] Instruction)] + (let [[estimator <arity>'] <arity>] + [estimator + (function (_ [<input_names>]) + (`` (<arity>' (hex <code>) (~~ (template.splice <arity_inputs>)))))])))] + + <definitions>' + ))] + + [..nullary + [["00" nop [] []] + <constants> + ["57" pop [] []] + ["58" pop2 [] []] + ["59" dup [] []] + ["5A" dup_x1 [] []] + ["5B" dup_x2 [] []] + ["5C" dup2 [] []] + ["5D" dup2_x1 [] []] + ["5E" dup2_x2 [] []] + ["5F" swap [] []] + <simple_register_loads> + <array_loads> + <simple_register_stores> + <array_stores> + <arithmetic> + ["79" lshl [] []] + ["7B" lshr [] []] + ["7D" lushr [] []] + <conversions> + <comparisons> + <returns> + ["BE" arraylength [] []] + ["BF" athrow [] []] + ["C2" monitorenter [] []] + ["C3" monitorexit [] []]]] + + [..unary/1 + [["12" ldc [[index U1]] [index]] + <register_loads> + <register_stores> + ["A9" ret [[register Register]] [register]] + ["BC" newarray [[type Primitive_Array_Type]] [(..code type)]]]] + + [..unary/1' + [["10" bipush [[byte S1]] [byte]]]] + + [..unary/2 + [["13" ldc_w/integer [[index (Index ///constant.Integer)]] [(///index.value index)]] + ["13" ldc_w/float [[index (Index ///constant.Float)]] [(///index.value index)]] + ["13" ldc_w/string [[index (Index ///constant.String)]] [(///index.value index)]] + ["14" ldc2_w/long [[index (Index ///constant.Long)]] [(///index.value index)]] + ["14" ldc2_w/double [[index (Index ///constant.Double)]] [(///index.value index)]] + <fields> + ["BB" new [[index (Index Class)]] [(///index.value index)]] + ["BD" anewarray [[index (Index Class)]] [(///index.value index)]] + ["C0" checkcast [[index (Index Class)]] [(///index.value index)]] + ["C1" instanceof [[index (Index Class)]] [(///index.value index)]] + ["B6" invokevirtual [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]] + ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]] + ["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]]]] + + [..unary/2' + [["11" sipush [[short S2]] [short]]]] + + [..jump/2 + [<jumps>]] + + [..jump/4 + [["C8" goto_w [[jump Big_Jump]] [jump]] + ["C9" jsr_w [[jump Big_Jump]] [jump]]]] + + [..binary/11 + [["84" iinc [[register Register] [byte U1]] [register byte]]]] + + [..binary/21 + [["C5" multianewarray [[index (Index Class)] [count U1]] [(///index.value index) count]]]] + + [..trinary/211 + [["B9" invokeinterface [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index) count (try.assume (///unsigned.u1 0))]]]] + )) + +(def: (switch_padding offset) + (-> Nat Nat) + (let [parameter_start (n.+ (///unsigned.value ..opcode_size) + offset)] + (n.% 4 + (n.- (n.% 4 parameter_start) + 4)))) + +(def: #export tableswitch + [(-> Nat Estimator) + (-> S4 Big_Jump [Big_Jump (List Big_Jump)] Instruction)] + (let [estimator (: (-> Nat Estimator) + (function (_ amount_of_afterwards offset) + (|> ($_ n.+ + (///unsigned.value ..opcode_size) + (switch_padding (///unsigned.value (//address.value offset))) + (///unsigned.value ..big_jump_size) + (///unsigned.value ..integer_size) + (///unsigned.value ..integer_size) + (n.* (///unsigned.value ..big_jump_size) + (inc amount_of_afterwards))) + ///unsigned.u2 + try.assume)))] + [estimator + (function (_ minimum default [at_minimum afterwards]) + (let [amount_of_afterwards (list.size afterwards) + estimator (estimator amount_of_afterwards)] + (function (_ [size mutation]) + (let [padding (switch_padding size) + tableswitch_size (try.assume + (do {! try.monad} + [size (///unsigned.u2 size)] + (\ ! map (|>> estimator ///unsigned.value) + (//address.move size //address.start)))) + tableswitch_mutation (: Mutation + (function (_ [offset binary]) + [(n.+ tableswitch_size offset) + (try.assume + (do {! try.monad} + [amount_of_afterwards (|> amount_of_afterwards .int ///signed.s4) + maximum (///signed.+/4 minimum amount_of_afterwards) + _ (binary.write/8 offset (hex "AA") binary) + #let [offset (n.+ (///unsigned.value ..opcode_size) offset)] + _ (case padding + 3 (do ! + [_ (binary.write/8 offset 0 binary)] + (binary.write/16 (inc offset) 0 binary)) + 2 (binary.write/16 offset 0 binary) + 1 (binary.write/8 offset 0 binary) + _ (wrap binary)) + #let [offset (n.+ padding offset)] + _ (binary.write/32 offset (///signed.value default) binary) + #let [offset (n.+ (///unsigned.value ..big_jump_size) offset)] + _ (binary.write/32 offset (///signed.value minimum) binary) + #let [offset (n.+ (///unsigned.value ..integer_size) offset)] + _ (binary.write/32 offset (///signed.value maximum) binary)] + (loop [offset (n.+ (///unsigned.value ..integer_size) offset) + afterwards (: (List Big_Jump) + (#.Cons at_minimum afterwards))] + (case afterwards + #.Nil + (wrap binary) + + (#.Cons head tail) + (do ! + [_ (binary.write/32 offset (///signed.value head) binary)] + (recur (n.+ (///unsigned.value ..big_jump_size) offset) + tail))))))]))] + [(n.+ tableswitch_size + size) + (|>> mutation tableswitch_mutation)]))))])) + +(def: #export lookupswitch + [(-> Nat Estimator) + (-> Big_Jump (List [S4 Big_Jump]) Instruction)] + (let [case_size (n.+ (///unsigned.value ..integer_size) + (///unsigned.value ..big_jump_size)) + estimator (: (-> Nat Estimator) + (function (_ amount_of_cases offset) + (|> ($_ n.+ + (///unsigned.value ..opcode_size) + (switch_padding (///unsigned.value (//address.value offset))) + (///unsigned.value ..big_jump_size) + (///unsigned.value ..integer_size) + (n.* amount_of_cases case_size)) + ///unsigned.u2 + try.assume)))] + [estimator + (function (_ default cases) + (let [amount_of_cases (list.size cases) + estimator (estimator amount_of_cases)] + (function (_ [size mutation]) + (let [padding (switch_padding size) + lookupswitch_size (try.assume + (do {! try.monad} + [size (///unsigned.u2 size)] + (\ ! map (|>> estimator ///unsigned.value) + (//address.move size //address.start)))) + lookupswitch_mutation (: Mutation + (function (_ [offset binary]) + [(n.+ lookupswitch_size offset) + (try.assume + (do {! try.monad} + [_ (binary.write/8 offset (hex "AB") binary) + #let [offset (n.+ (///unsigned.value ..opcode_size) offset)] + _ (case padding + 3 (do ! + [_ (binary.write/8 offset 0 binary)] + (binary.write/16 (inc offset) 0 binary)) + 2 (binary.write/16 offset 0 binary) + 1 (binary.write/8 offset 0 binary) + _ (wrap binary)) + #let [offset (n.+ padding offset)] + _ (binary.write/32 offset (///signed.value default) binary) + #let [offset (n.+ (///unsigned.value ..big_jump_size) offset)] + _ (binary.write/32 offset amount_of_cases binary)] + (loop [offset (n.+ (///unsigned.value ..integer_size) offset) + cases cases] + (case cases + #.Nil + (wrap binary) + + (#.Cons [value jump] tail) + (do ! + [_ (binary.write/32 offset (///signed.value value) binary) + _ (binary.write/32 (n.+ (///unsigned.value ..integer_size) offset) (///signed.value jump) binary)] + (recur (n.+ case_size offset) + tail))))))]))] + [(n.+ lookupswitch_size + size) + (|>> mutation lookupswitch_mutation)]))))])) + +(implementation: #export monoid + (Monoid Instruction) + + (def: identity ..empty) + + (def: (compose left right) + (|>> left right))) diff --git a/stdlib/source/library/lux/target/jvm/bytecode/jump.lux b/stdlib/source/library/lux/target/jvm/bytecode/jump.lux new file mode 100644 index 000000000..2873ef781 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/bytecode/jump.lux @@ -0,0 +1,27 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [data + ["." format #_ + ["#" binary (#+ Writer)]]]]] + ["." /// #_ + [encoding + ["#." signed (#+ S2 S4)]]]) + +(type: #export Jump S2) + +(def: #export equivalence + (Equivalence Jump) + ///signed.equivalence) + +(def: #export writer + (Writer Jump) + ///signed.writer/2) + +(type: #export Big_Jump S4) + +(def: #export lift + (-> Jump Big_Jump) + ///signed.lift/4) diff --git a/stdlib/source/library/lux/target/jvm/class.lux b/stdlib/source/library/lux/target/jvm/class.lux new file mode 100644 index 000000000..7f6705de8 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/class.lux @@ -0,0 +1,134 @@ + (.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + ["." monad (#+ do)]] + [control + ["." state] + ["." try (#+ Try)]] + [data + ["." product] + [format + [".F" binary (#+ Writer) ("#\." monoid)]] + [collection + ["." row (#+ Row)]]]]] + ["." // #_ + ["#." modifier (#+ Modifier modifiers:)] + ["#." version (#+ Version Minor Major)] + ["#." magic (#+ Magic)] + ["#." index (#+ Index)] + ["#." attribute (#+ Attribute)] + ["#." field (#+ Field)] + ["#." method (#+ Method)] + [encoding + ["#." unsigned] + ["#." name (#+ Internal)]] + ["#." constant (#+ Constant) + ["#/." pool (#+ Pool Resource)]]]) + +(type: #export #rec Class + {#magic Magic + #minor_version Minor + #major_version Major + #constant_pool Pool + #modifier (Modifier Class) + #this (Index //constant.Class) + #super (Index //constant.Class) + #interfaces (Row (Index //constant.Class)) + #fields (Row Field) + #methods (Row Method) + #attributes (Row Attribute)}) + +(modifiers: Class + ["0001" public] + ["0010" final] + ["0020" super] + ["0200" interface] + ["0400" abstract] + ["1000" synthetic] + ["2000" annotation] + ["4000" enum] + ) + +(def: #export equivalence + (Equivalence Class) + ($_ product.equivalence + //unsigned.equivalence + //unsigned.equivalence + //unsigned.equivalence + //constant/pool.equivalence + //modifier.equivalence + //index.equivalence + //index.equivalence + (row.equivalence //index.equivalence) + (row.equivalence //field.equivalence) + (row.equivalence //method.equivalence) + (row.equivalence //attribute.equivalence))) + +(def: (install_classes this super interfaces) + (-> Internal Internal (List Internal) + (Resource [(Index //constant.Class) (Index //constant.Class) (Row (Index //constant.Class))])) + (do {! //constant/pool.monad} + [@this (//constant/pool.class this) + @super (//constant/pool.class super) + @interfaces (: (Resource (Row (Index //constant.Class))) + (monad.fold ! (function (_ interface @interfaces) + (do ! + [@interface (//constant/pool.class interface)] + (wrap (row.add @interface @interfaces)))) + row.empty + interfaces))] + (wrap [@this @super @interfaces]))) + +(def: #export (class version modifier + this super interfaces + fields methods attributes) + (-> Major (Modifier Class) + Internal Internal (List Internal) + (List (Resource Field)) + (List (Resource Method)) + (Row Attribute) + (Try Class)) + (do try.monad + [[pool [@this @super @interfaces] =fields =methods] + (<| (state.run' //constant/pool.empty) + (do //constant/pool.monad + [classes (install_classes this super interfaces) + =fields (monad.seq //constant/pool.monad fields) + =methods (monad.seq //constant/pool.monad methods)] + (wrap [classes =fields =methods])))] + (wrap {#magic //magic.code + #minor_version //version.default_minor + #major_version version + #constant_pool pool + #modifier modifier + #this @this + #super @super + #interfaces @interfaces + #fields (row.from_list =fields) + #methods (row.from_list =methods) + #attributes attributes}))) + +(def: #export (writer class) + (Writer Class) + (`` ($_ binaryF\compose + (~~ (template [<writer> <slot>] + [(<writer> (get@ <slot> class))] + + [//magic.writer #magic] + [//version.writer #minor_version] + [//version.writer #major_version] + [//constant/pool.writer #constant_pool] + [//modifier.writer #modifier] + [//index.writer #this] + [//index.writer #super])) + (~~ (template [<writer> <slot>] + [((binaryF.row/16 <writer>) (get@ <slot> class))] + + [//index.writer #interfaces] + [//field.writer #fields] + [//method.writer #methods] + [//attribute.writer #attributes] + )) + ))) diff --git a/stdlib/source/library/lux/target/jvm/constant.lux b/stdlib/source/library/lux/target/jvm/constant.lux new file mode 100644 index 000000000..663dc472f --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/constant.lux @@ -0,0 +1,246 @@ +(.module: + [library + [lux #* + ["." ffi (#+ import:)] + ["@" target] + [abstract + [monad (#+ do)] + ["." equivalence (#+ Equivalence)]] + [data + ["." sum] + ["." product] + ["." text] + [format + [".F" binary (#+ Writer) ("#\." monoid)]] + [collection + ["." row (#+ Row)]]] + [macro + ["." template]] + [math + [number + ["." i32 (#+ I32)] + ["." i64] + ["." int] + ["." frac]]] + [type + abstract]]] + ["." / #_ + ["#." tag] + ["/#" // #_ + ["#." index (#+ Index)] + [type + ["#." category] + ["#." descriptor (#+ Descriptor)]] + [encoding + ["#." unsigned]]]]) + +(type: #export UTF8 Text) + +(def: utf8_writer + (Writer UTF8) + binaryF.utf8/16) + +(abstract: #export Class + (Index UTF8) + + (def: #export index + (-> Class (Index UTF8)) + (|>> :representation)) + + (def: #export class + (-> (Index UTF8) Class) + (|>> :abstraction)) + + (def: #export class_equivalence + (Equivalence Class) + (\ equivalence.functor map + ..index + //index.equivalence)) + + (def: class_writer + (Writer Class) + (|>> :representation //index.writer)) + ) + +(import: java/lang/Float + ["#::." + (#static floatToRawIntBits #manual [float] int)]) + +(implementation: #export float_equivalence + (Equivalence java/lang/Float) + + (def: (= parameter subject) + (for {@.old + ("jvm feq" parameter subject) + + @.jvm + ("jvm float =" + ("jvm object cast" parameter) + ("jvm object cast" subject))}))) + +(import: java/lang/Double + ["#::." + (#static doubleToRawLongBits [double] long)]) + +(abstract: #export (Value kind) + kind + + (def: #export value + (All [kind] (-> (Value kind) kind)) + (|>> :representation)) + + (def: #export (value_equivalence Equivalence<kind>) + (All [kind] + (-> (Equivalence kind) + (Equivalence (Value kind)))) + (\ equivalence.functor map + (|>> :representation) + Equivalence<kind>)) + + (template [<constructor> <type> <marker>] + [(type: #export <type> (Value <marker>)) + + (def: #export <constructor> + (-> <marker> <type>) + (|>> :abstraction))] + + [integer Integer I32] + [float Float java/lang/Float] + [long Long .Int] + [double Double Frac] + [string String (Index UTF8)] + ) + + (template [<writer_name> <type> <write> <writer>] + [(def: <writer_name> + (Writer <type>) + (`` (|>> :representation + (~~ (template.splice <write>)) + (~~ (template.splice <writer>)))))] + + [integer_writer Integer [] [binaryF.bits/32]] + [float_writer Float [java/lang/Float::floatToRawIntBits ffi.int_to_long (:as I64)] [i32.i32 binaryF.bits/32]] + [long_writer Long [] [binaryF.bits/64]] + [double_writer Double [java/lang/Double::doubleToRawLongBits] [binaryF.bits/64]] + [string_writer String [] [//index.writer]] + ) + ) + +(type: #export (Name_And_Type of) + {#name (Index UTF8) + #descriptor (Index (Descriptor of))}) + +(type: #export (Reference of) + {#class (Index Class) + #name_and_type (Index (Name_And_Type of))}) + +(template [<type> <equivalence> <writer>] + [(def: #export <equivalence> + (Equivalence (<type> Any)) + ($_ product.equivalence + //index.equivalence + //index.equivalence)) + + (def: <writer> + (Writer (<type> Any)) + ($_ binaryF.and + //index.writer + //index.writer))] + + [Name_And_Type name_and_type_equivalence name_and_type_writer] + [Reference reference_equivalence reference_writer] + ) + +(type: #export Constant + (#UTF8 UTF8) + (#Integer Integer) + (#Float Float) + (#Long Long) + (#Double Double) + (#Class Class) + (#String String) + (#Field (Reference //category.Value)) + (#Method (Reference //category.Method)) + (#Interface_Method (Reference //category.Method)) + (#Name_And_Type (Name_And_Type Any))) + +(def: #export (size constant) + (-> Constant Nat) + (case constant + (^or (#Long _) (#Double _)) + 2 + + _ + 1)) + +(def: #export equivalence + (Equivalence Constant) + ## TODO: Delete the explicit "implementation" and use the combinator + ## version below as soon as the new format for variants is implemented. + (implementation + (def: (= reference sample) + (case [reference sample] + (^template [<tag> <equivalence>] + [[(<tag> reference) (<tag> sample)] + (\ <equivalence> = reference sample)]) + ([#UTF8 text.equivalence] + [#Integer (..value_equivalence i32.equivalence)] + [#Long (..value_equivalence int.equivalence)] + [#Float (..value_equivalence float_equivalence)] + [#Double (..value_equivalence frac.equivalence)] + [#Class ..class_equivalence] + [#String (..value_equivalence //index.equivalence)] + [#Field ..reference_equivalence] + [#Method ..reference_equivalence] + [#Interface_Method ..reference_equivalence] + [#Name_And_Type ..name_and_type_equivalence]) + + _ + false))) + ## ($_ sum.equivalence + ## ## #UTF8 + ## text.equivalence + ## ## #Long + ## (..value_equivalence int.equivalence) + ## ## #Double + ## (..value_equivalence frac.equivalence) + ## ## #Class + ## ..class_equivalence + ## ## #String + ## (..value_equivalence //index.equivalence) + ## ## #Field + ## ..reference_equivalence + ## ## #Method + ## ..reference_equivalence + ## ## #Interface_Method + ## ..reference_equivalence + ## ## #Name_And_Type + ## ..name_and_type_equivalence + ## ) + ) + +(def: #export writer + (Writer Constant) + (with_expansions [<constants> (as_is [#UTF8 /tag.utf8 ..utf8_writer] + [#Integer /tag.integer ..integer_writer] + [#Float /tag.float ..float_writer] + [#Long /tag.long ..long_writer] + [#Double /tag.double ..double_writer] + [#Class /tag.class ..class_writer] + [#String /tag.string ..string_writer] + [#Field /tag.field ..reference_writer] + [#Method /tag.method ..reference_writer] + [#Interface_Method /tag.interface_method ..reference_writer] + [#Name_And_Type /tag.name_and_type ..name_and_type_writer] + ## TODO: Method_Handle + ## TODO: Method_Type + ## TODO: Invoke_Dynamic + )] + (function (_ value) + (case value + (^template [<case> <tag> <writer>] + [(<case> value) + (binaryF\compose (/tag.writer <tag>) + (<writer> value))]) + (<constants>) + )))) diff --git a/stdlib/source/library/lux/target/jvm/constant/pool.lux b/stdlib/source/library/lux/target/jvm/constant/pool.lux new file mode 100644 index 000000000..e7fa465d8 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/constant/pool.lux @@ -0,0 +1,158 @@ +(.module: + [library + [lux #* + ["." ffi] + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ Monad do)]] + [control + ["." state (#+ State')] + ["." try (#+ Try)]] + [data + ["." product] + ["." text] + ["." format #_ + ["#" binary (#+ Writer) ("specification\." monoid)]] + [collection + ["." row (#+ Row) ("#\." fold)]]] + [macro + ["." template]] + [math + [number + ["." i32] + ["n" nat] + ["." int] + ["." frac]]] + [type + abstract]]] + ["." // (#+ UTF8 String Class Integer Float Long Double Constant Name_And_Type Reference) + [// + [encoding + ["#." name (#+ Internal External)] + ["#." unsigned]] + ["#." index (#+ Index)] + [type + [category (#+ Value Method)] + ["#." descriptor (#+ Descriptor)]]]]) + +(type: #export Pool [Index (Row [Index Constant])]) + +(def: #export equivalence + (Equivalence Pool) + (product.equivalence //index.equivalence + (row.equivalence (product.equivalence //index.equivalence + //.equivalence)))) + +(type: #export (Resource a) + (State' Try Pool a)) + +(def: #export monad + (Monad Resource) + (state.with try.monad)) + +(template: (!add <tag> <equivalence> <value>) + (function (_ [current pool]) + (let [<value>' <value>] + (with_expansions [<try_again> (as_is (recur (.inc idx)))] + (loop [idx 0] + (case (row.nth idx pool) + (#try.Success entry) + (case entry + [index (<tag> reference)] + (if (\ <equivalence> = reference <value>') + (#try.Success [[current pool] + index]) + <try_again>) + + _ + <try_again>) + + (#try.Failure _) + (let [new (<tag> <value>')] + (do {! try.monad} + [@new (//unsigned.u2 (//.size new)) + next (: (Try Index) + (|> current + //index.value + (//unsigned.+/2 @new) + (\ ! map //index.index)))] + (wrap [[next + (row.add [current new] pool)] + current]))))))))) + +(template: (!index <index>) + (|> <index> //index.value //unsigned.value)) + +(type: (Adder of) + (-> of (Resource (Index of)))) + +(template [<name> <type> <tag> <equivalence>] + [(def: #export (<name> value) + (Adder <type>) + (!add <tag> <equivalence> value))] + + [integer Integer #//.Integer (//.value_equivalence i32.equivalence)] + [float Float #//.Float (//.value_equivalence //.float_equivalence)] + [long Long #//.Long (//.value_equivalence int.equivalence)] + [double Double #//.Double (//.value_equivalence frac.equivalence)] + [utf8 UTF8 #//.UTF8 text.equivalence] + ) + +(def: #export (string value) + (-> Text (Resource (Index String))) + (do ..monad + [@value (utf8 value) + #let [value (//.string @value)]] + (!add #//.String (//.value_equivalence //index.equivalence) value))) + +(def: #export (class name) + (-> Internal (Resource (Index Class))) + (do ..monad + [@name (utf8 (//name.read name)) + #let [value (//.class @name)]] + (!add #//.Class //.class_equivalence value))) + +(def: #export (descriptor value) + (All [kind] + (-> (Descriptor kind) + (Resource (Index (Descriptor kind))))) + (let [value (//descriptor.descriptor value)] + (!add #//.UTF8 text.equivalence value))) + +(type: #export (Member of) + {#name UTF8 + #descriptor (Descriptor of)}) + +(def: #export (name_and_type [name descriptor]) + (All [of] + (-> (Member of) (Resource (Index (Name_And_Type of))))) + (do ..monad + [@name (utf8 name) + @descriptor (..descriptor descriptor)] + (!add #//.Name_And_Type //.name_and_type_equivalence {#//.name @name #//.descriptor @descriptor}))) + +(template [<name> <tag> <of>] + [(def: #export (<name> class member) + (-> External (Member <of>) (Resource (Index (Reference <of>)))) + (do ..monad + [@class (..class (//name.internal class)) + @name_and_type (name_and_type member)] + (!add <tag> //.reference_equivalence {#//.class @class #//.name_and_type @name_and_type})))] + + [field #//.Field Value] + [method #//.Method Method] + [interface_method #//.Interface_Method Method] + ) + +(def: #export writer + (Writer Pool) + (function (_ [next pool]) + (row\fold (function (_ [_index post] pre) + (specification\compose pre (//.writer post))) + (format.bits/16 (!index next)) + pool))) + +(def: #export empty + Pool + [(|> 1 //unsigned.u2 try.assume //index.index) + row.empty]) diff --git a/stdlib/source/library/lux/target/jvm/constant/tag.lux b/stdlib/source/library/lux/target/jvm/constant/tag.lux new file mode 100644 index 000000000..414de077b --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/constant/tag.lux @@ -0,0 +1,50 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [control + ["." try]] + [data + [format + [binary (#+ Writer)]]] + [type + abstract]]] + ["." /// #_ + [encoding + ["#." unsigned (#+ U1) ("u1//." equivalence)]]]) + +(abstract: #export Tag + U1 + + (implementation: #export equivalence + (Equivalence Tag) + (def: (= reference sample) + (u1//= (:representation reference) + (:representation sample)))) + + (template [<code> <name>] + [(def: #export <name> + Tag + (|> <code> ///unsigned.u1 try.assume :abstraction))] + + [01 utf8] + [03 integer] + [04 float] + [05 long] + [06 double] + [07 class] + [08 string] + [09 field] + [10 method] + [11 interface_method] + [12 name_and_type] + [15 method_handle] + [16 method_type] + [18 invoke_dynamic] + ) + + (def: #export writer + (Writer Tag) + (|>> :representation ///unsigned.writer/1)) + ) diff --git a/stdlib/source/library/lux/target/jvm/encoding/name.lux b/stdlib/source/library/lux/target/jvm/encoding/name.lux new file mode 100644 index 000000000..5a1982d3e --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/encoding/name.lux @@ -0,0 +1,40 @@ +(.module: + [library + [lux #* + [data + ["." text + ["%" format (#+ format)]]] + [type + abstract]]]) + +(def: #export internal_separator "/") +(def: #export external_separator ".") + +(type: #export External Text) + +(abstract: #export Internal + Text + + (def: #export internal + (-> External Internal) + (|>> (text.replace_all ..external_separator + ..internal_separator) + :abstraction)) + + (def: #export read + (-> Internal Text) + (|>> :representation)) + + (def: #export external + (-> Internal External) + (|>> :representation + (text.replace_all ..internal_separator + ..external_separator)))) + +(def: #export sanitize + (-> Text External) + (|>> ..internal ..external)) + +(def: #export (qualify package class) + (-> Text External External) + (format (..sanitize package) ..external_separator class)) diff --git a/stdlib/source/library/lux/target/jvm/encoding/signed.lux b/stdlib/source/library/lux/target/jvm/encoding/signed.lux new file mode 100644 index 000000000..a914dfc3c --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/encoding/signed.lux @@ -0,0 +1,107 @@ +(.module: + [library + [lux (#- int) + [abstract + [equivalence (#+ Equivalence)] + [order (#+ Order)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + [text + ["%" format (#+ format)]] + ["." format #_ + ["#" binary (#+ Writer)]]] + [macro + ["." template]] + [math + [number + ["." i64] + ["n" nat] + ["i" int]]] + [type + abstract]]]) + +(abstract: #export (Signed brand) + Int + + (def: #export value + (-> (Signed Any) Int) + (|>> :representation)) + + (implementation: #export equivalence + (All [brand] (Equivalence (Signed brand))) + (def: (= reference sample) + (i.= (:representation reference) (:representation sample)))) + + (implementation: #export order + (All [brand] (Order (Signed brand))) + + (def: &equivalence ..equivalence) + (def: (< reference sample) + (i.< (:representation reference) (:representation sample)))) + + (exception: #export (value_exceeds_the_scope {value Int} + {scope Nat}) + (exception.report + ["Value" (%.int value)] + ["Scope (in bytes)" (%.nat scope)])) + + (template [<bytes> <name> <size> <constructor> <maximum> <+> <->] + [(with_expansions [<raw> (template.identifier [<name> "'"])] + (abstract: #export <raw> Any) + (type: #export <name> (Signed <raw>))) + + (def: #export <size> <bytes>) + + (def: #export <maximum> + <name> + (|> <bytes> (n.* i64.bits_per_byte) dec i64.mask :abstraction)) + + (def: #export <constructor> + (-> Int (Try <name>)) + (let [positive (|> <bytes> (n.* i64.bits_per_byte) i64.mask) + negative (|> positive .int (i.right_shift 1) i64.not)] + (function (_ value) + (if (i.= (if (i.< +0 value) + (i64.or negative value) + (i64.and positive value)) + value) + (#try.Success (:abstraction value)) + (exception.throw ..value_exceeds_the_scope [value <size>]))))) + + (template [<abstract_operation> <concrete_operation>] + [(def: #export (<abstract_operation> parameter subject) + (-> <name> <name> (Try <name>)) + (<constructor> + (<concrete_operation> (:representation parameter) + (:representation subject))))] + + [<+> i.+] + [<-> i.-] + )] + + [1 S1 bytes/1 s1 maximum/1 +/1 -/1] + [2 S2 bytes/2 s2 maximum/2 +/2 -/2] + [4 S4 bytes/4 s4 maximum/4 +/4 -/4] + ) + + (template [<name> <from> <to>] + [(def: #export <name> + (-> <from> <to>) + (|>> :transmutation))] + + [lift/2 S1 S2] + [lift/4 S2 S4] + ) + + (template [<writer_name> <type> <writer>] + [(def: #export <writer_name> + (Writer <type>) + (|>> :representation <writer>))] + + [writer/1 S1 format.bits/8] + [writer/2 S2 format.bits/16] + [writer/4 S4 format.bits/32] + ) + ) diff --git a/stdlib/source/library/lux/target/jvm/encoding/unsigned.lux b/stdlib/source/library/lux/target/jvm/encoding/unsigned.lux new file mode 100644 index 000000000..d8299fa65 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/encoding/unsigned.lux @@ -0,0 +1,121 @@ +(.module: + [library + [lux (#- nat) + [abstract + [equivalence (#+ Equivalence)] + [order (#+ Order)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + [text + ["%" format (#+ format)]] + ["." format #_ + ["#" binary (#+ Writer)]]] + [macro + ["." template]] + [math + [number + ["n" nat] + ["." i64]]] + [type + abstract]]]) + +(abstract: #export (Unsigned brand) + Nat + + (def: #export value + (-> (Unsigned Any) Nat) + (|>> :representation)) + + (implementation: #export equivalence + (All [brand] (Equivalence (Unsigned brand))) + (def: (= reference sample) + (n.= (:representation reference) + (:representation sample)))) + + (implementation: #export order + (All [brand] (Order (Unsigned brand))) + + (def: &equivalence ..equivalence) + (def: (< reference sample) + (n.< (:representation reference) + (:representation sample)))) + + (exception: #export (value_exceeds_the_maximum {type Name} + {value Nat} + {maximum (Unsigned Any)}) + (exception.report + ["Type" (%.name type)] + ["Value" (%.nat value)] + ["Maximum" (%.nat (:representation maximum))])) + + (exception: #export [brand] (subtraction_cannot_yield_negative_value + {type Name} + {parameter (Unsigned brand)} + {subject (Unsigned brand)}) + (exception.report + ["Type" (%.name type)] + ["Parameter" (%.nat (:representation parameter))] + ["Subject" (%.nat (:representation subject))])) + + (template [<bytes> <name> <size> <constructor> <maximum> <+> <-> <max>] + [(with_expansions [<raw> (template.identifier [<name> "'"])] + (abstract: #export <raw> Any) + (type: #export <name> (Unsigned <raw>))) + + (def: #export <size> <bytes>) + + (def: #export <maximum> + <name> + (|> <bytes> (n.* i64.bits_per_byte) i64.mask :abstraction)) + + (def: #export (<constructor> value) + (-> Nat (Try <name>)) + (if (n.<= (:representation <maximum>) value) + (#try.Success (:abstraction value)) + (exception.throw ..value_exceeds_the_maximum [(name_of <name>) value <maximum>]))) + + (def: #export (<+> parameter subject) + (-> <name> <name> (Try <name>)) + (<constructor> + (n.+ (:representation parameter) + (:representation subject)))) + + (def: #export (<-> parameter subject) + (-> <name> <name> (Try <name>)) + (let [parameter' (:representation parameter) + subject' (:representation subject)] + (if (n.<= subject' parameter') + (#try.Success (:abstraction (n.- parameter' subject'))) + (exception.throw ..subtraction_cannot_yield_negative_value [(name_of <name>) parameter subject])))) + + (def: #export (<max> left right) + (-> <name> <name> <name>) + (:abstraction (n.max (:representation left) + (:representation right))))] + + [1 U1 bytes/1 u1 maximum/1 +/1 -/1 max/1] + [2 U2 bytes/2 u2 maximum/2 +/2 -/2 max/2] + [4 U4 bytes/4 u4 maximum/4 +/4 -/4 max/4] + ) + + (template [<name> <from> <to>] + [(def: #export <name> + (-> <from> <to>) + (|>> :transmutation))] + + [lift/2 U1 U2] + [lift/4 U2 U4] + ) + + (template [<writer_name> <type> <writer>] + [(def: #export <writer_name> + (Writer <type>) + (|>> :representation <writer>))] + + [writer/1 U1 format.bits/8] + [writer/2 U2 format.bits/16] + [writer/4 U4 format.bits/32] + ) + ) diff --git a/stdlib/source/library/lux/target/jvm/field.lux b/stdlib/source/library/lux/target/jvm/field.lux new file mode 100644 index 000000000..aa71794a5 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/field.lux @@ -0,0 +1,70 @@ +(.module: + [library + [lux (#- Type static) + [abstract + [equivalence (#+ Equivalence)] + ["." monad (#+ do)]] + [data + ["." product] + [format + [".F" binary (#+ Writer) ("#\." monoid)]] + [collection + ["." row (#+ Row)]]]]] + ["." // #_ + ["." modifier (#+ Modifier modifiers:)] + ["#." constant (#+ UTF8) + ["#/." pool (#+ Pool Resource)]] + ["#." index (#+ Index)] + ["#." attribute (#+ Attribute)] + ["#." type (#+ Type) + [category (#+ Value)] + [descriptor (#+ Descriptor)]]]) + +(type: #export #rec Field + {#modifier (Modifier Field) + #name (Index UTF8) + #descriptor (Index (Descriptor Value)) + #attributes (Row Attribute)}) + +(modifiers: Field + ["0001" public] + ["0002" private] + ["0004" protected] + ["0008" static] + ["0010" final] + ["0040" volatile] + ["0080" transient] + ["1000" synthetic] + ["4000" enum] + ) + +(def: #export equivalence + (Equivalence Field) + ($_ product.equivalence + modifier.equivalence + //index.equivalence + //index.equivalence + (row.equivalence //attribute.equivalence))) + +(def: #export (writer field) + (Writer Field) + (`` ($_ binaryF\compose + (~~ (template [<writer> <slot>] + [(<writer> (get@ <slot> field))] + + [modifier.writer #modifier] + [//index.writer #name] + [//index.writer #descriptor] + [(binaryF.row/16 //attribute.writer) #attributes])) + ))) + +(def: #export (field modifier name type attributes) + (-> (Modifier Field) UTF8 (Type Value) (Row Attribute) + (Resource Field)) + (do //constant/pool.monad + [@name (//constant/pool.utf8 name) + @descriptor (//constant/pool.descriptor (//type.descriptor type))] + (wrap {#modifier modifier + #name @name + #descriptor @descriptor + #attributes attributes}))) diff --git a/stdlib/source/library/lux/target/jvm/index.lux b/stdlib/source/library/lux/target/jvm/index.lux new file mode 100644 index 000000000..851d6903f --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/index.lux @@ -0,0 +1,38 @@ +(.module: + [library + [lux #* + [abstract + ["." equivalence (#+ Equivalence)]] + [data + [format + [binary (#+ Writer)]]] + [type + abstract]]] + ["." // #_ + [encoding + ["#." unsigned (#+ U2)]]]) + +(def: #export length + //unsigned.bytes/2) + +(abstract: #export (Index kind) + U2 + + (def: #export index + (All [kind] (-> U2 (Index kind))) + (|>> :abstraction)) + + (def: #export value + (-> (Index Any) U2) + (|>> :representation)) + + (def: #export equivalence + (All [kind] (Equivalence (Index kind))) + (\ equivalence.functor map + ..value + //unsigned.equivalence)) + + (def: #export writer + (All [kind] (Writer (Index kind))) + (|>> :representation //unsigned.writer/2)) + ) diff --git a/stdlib/source/library/lux/target/jvm/loader.lux b/stdlib/source/library/lux/target/jvm/loader.lux new file mode 100644 index 000000000..8b86321ca --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/loader.lux @@ -0,0 +1,143 @@ +(.module: + [library + [lux #* + ["@" target] + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["." io (#+ IO)] + [concurrency + ["." atom (#+ Atom)]]] + [data + ["." binary (#+ Binary)] + ["." text + ["%" format (#+ format)]] + [collection + ["." array] + ["." dictionary (#+ Dictionary)]]] + ["." ffi (#+ import: object do_to)]]]) + +(type: #export Library + (Atom (Dictionary Text Binary))) + +(exception: #export (already_stored {class Text}) + (exception.report + ["Class" class])) + +(exception: #export (unknown {class Text} {known_classes (List Text)}) + (exception.report + ["Class" class] + ["Known classes" (exception.enumerate (|>>) known_classes)])) + +(exception: #export (cannot_define {class Text} {error Text}) + (exception.report + ["Class" class] + ["Error" error])) + +(import: java/lang/Object + ["#::." + (getClass [] (java/lang/Class java/lang/Object))]) + +(import: java/lang/String) + +(import: java/lang/reflect/Method + ["#::." + (invoke [java/lang/Object [java/lang/Object]] #try java/lang/Object)]) + +(import: (java/lang/Class a) + ["#::." + (getDeclaredMethod [java/lang/String [(java/lang/Class [? < java/lang/Object])]] java/lang/reflect/Method)]) + +(import: java/lang/Integer + ["#::." + (#static TYPE (java/lang/Class java/lang/Integer))]) + +(import: java/lang/reflect/AccessibleObject + ["#::." + (setAccessible [boolean] void)]) + +(import: java/lang/ClassLoader + ["#::." + (loadClass [java/lang/String] + #io #try (java/lang/Class java/lang/Object))]) + +(with_expansions [<elemT> (as_is (java/lang/Class java/lang/Object))] + (def: java/lang/ClassLoader::defineClass + java/lang/reflect/Method + (let [signature (|> (ffi.array <elemT> 4) + (ffi.array_write 0 (:as <elemT> + (ffi.class_for java/lang/String))) + (ffi.array_write 1 (java/lang/Object::getClass (ffi.array byte 0))) + (ffi.array_write 2 (:as <elemT> + (java/lang/Integer::TYPE))) + (ffi.array_write 3 (:as <elemT> + (java/lang/Integer::TYPE))))] + (do_to (java/lang/Class::getDeclaredMethod "defineClass" + signature + (ffi.class_for java/lang/ClassLoader)) + (java/lang/reflect/AccessibleObject::setAccessible true))))) + +(def: #export (define class_name bytecode loader) + (-> Text Binary java/lang/ClassLoader (Try java/lang/Object)) + (let [signature (array.from_list (list (:as java/lang/Object + class_name) + (:as java/lang/Object + bytecode) + (:as java/lang/Object + (|> 0 + (:as (primitive "java.lang.Long")) + ffi.long_to_int)) + (:as java/lang/Object + (|> bytecode + binary.size + (:as (primitive "java.lang.Long")) + ffi.long_to_int))))] + (java/lang/reflect/Method::invoke loader signature java/lang/ClassLoader::defineClass))) + +(def: #export (new_library _) + (-> Any Library) + (atom.atom (dictionary.new text.hash))) + +(def: #export (memory library) + (-> Library java/lang/ClassLoader) + (with_expansions [<cast> (for {@.old + (<|) + + @.jvm + "jvm object cast"})] + (<| <cast> + (object [] java/lang/ClassLoader [] + [] + (java/lang/ClassLoader (findClass self {class_name java/lang/String}) + (java/lang/Class [? < java/lang/Object]) + #throws [java/lang/ClassNotFoundException] + (let [class_name (:as Text class_name) + classes (|> library atom.read io.run)] + (case (dictionary.get class_name classes) + (#.Some bytecode) + (case (..define class_name bytecode (<| <cast> self)) + (#try.Success class) + (:assume class) + + (#try.Failure error) + (error! (exception.construct ..cannot_define [class_name error]))) + + #.None + (error! (exception.construct ..unknown [class_name (dictionary.keys classes)]))))))))) + +(def: #export (store name bytecode library) + (-> Text Binary Library (IO (Try Any))) + (do {! io.monad} + [library' (atom.read library)] + (if (dictionary.key? library' name) + (wrap (exception.throw ..already_stored name)) + (do ! + [_ (atom.update (dictionary.put name bytecode) library)] + (wrap (#try.Success [])))))) + +(def: #export (load name loader) + (-> Text java/lang/ClassLoader + (IO (Try (java/lang/Class java/lang/Object)))) + (java/lang/ClassLoader::loadClass name loader)) diff --git a/stdlib/source/library/lux/target/jvm/magic.lux b/stdlib/source/library/lux/target/jvm/magic.lux new file mode 100644 index 000000000..70859362b --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/magic.lux @@ -0,0 +1,20 @@ +(.module: + [library + [lux #* + [control + ["." try]] + [math + [number (#+ hex)]]]] + ["." // #_ + [encoding + ["#." unsigned (#+ U4)]]]) + +(type: #export Magic + U4) + +(def: #export code + Magic + (|> (hex "CAFEBABE") //unsigned.u4 try.assume)) + +(def: #export writer + //unsigned.writer/4) diff --git a/stdlib/source/library/lux/target/jvm/method.lux b/stdlib/source/library/lux/target/jvm/method.lux new file mode 100644 index 000000000..e832b1667 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/method.lux @@ -0,0 +1,104 @@ +(.module: + [library + [lux (#- Type static) + [abstract + [equivalence (#+ Equivalence)] + ["." monad (#+ do)]] + [control + ["." try]] + [data + ["." product] + ["." format #_ + ["#" binary (#+ Writer) ("#\." monoid)]] + [collection + ["." row (#+ Row)]]]]] + ["." // #_ + ["#." modifier (#+ Modifier modifiers:)] + ["#." index (#+ Index)] + ["#." attribute (#+ Attribute) + ["#/." code]] + ["#." constant (#+ UTF8) + ["#/." pool (#+ Pool Resource)]] + ["#." bytecode (#+ Bytecode) + ["#/." environment (#+ Environment)] + ["#/." instruction]] + ["#." type (#+ Type) + ["#/." category] + ["#." descriptor (#+ Descriptor)]]]) + +(type: #export #rec Method + {#modifier (Modifier Method) + #name (Index UTF8) + #descriptor (Index (Descriptor //type/category.Method)) + #attributes (Row Attribute)}) + +(modifiers: Method + ["0001" public] + ["0002" private] + ["0004" protected] + ["0008" static] + ["0010" final] + ["0020" synchronized] + ["0040" bridge] + ["0080" var_args] + ["0100" native] + ["0400" abstract] + ["0800" strict] + ["1000" synthetic] + ) + +(def: #export (method modifier name type attributes code) + (-> (Modifier Method) UTF8 (Type //type/category.Method) (List (Resource Attribute)) (Maybe (Bytecode Any)) + (Resource Method)) + (do {! //constant/pool.monad} + [@name (//constant/pool.utf8 name) + @descriptor (//constant/pool.descriptor (//type.descriptor type)) + attributes (|> attributes + (monad.seq !) + (\ ! map row.from_list)) + attributes (case code + (#.Some code) + (do ! + [environment (case (if (//modifier.has? static modifier) + (//bytecode/environment.static type) + (//bytecode/environment.virtual type)) + (#try.Success environment) + (wrap environment) + + (#try.Failure error) + (function (_ _) (#try.Failure error))) + [environment exceptions instruction output] (//bytecode.resolve environment code) + #let [bytecode (|> instruction //bytecode/instruction.run format.instance)] + @code (//attribute.code {#//attribute/code.limit (get@ #//bytecode/environment.limit environment) + #//attribute/code.code bytecode + #//attribute/code.exception_table exceptions + #//attribute/code.attributes (row.row)})] + (wrap (row.add @code attributes))) + + #.None + (wrap attributes))] + (wrap {#modifier modifier + #name @name + #descriptor @descriptor + #attributes attributes}))) + +(def: #export equivalence + (Equivalence Method) + ($_ product.equivalence + //modifier.equivalence + //index.equivalence + //index.equivalence + (row.equivalence //attribute.equivalence) + )) + +(def: #export (writer field) + (Writer Method) + (`` ($_ format\compose + (~~ (template [<writer> <slot>] + [(<writer> (get@ <slot> field))] + + [//modifier.writer #modifier] + [//index.writer #name] + [//index.writer #descriptor] + [(format.row/16 //attribute.writer) #attributes])) + ))) diff --git a/stdlib/source/library/lux/target/jvm/modifier.lux b/stdlib/source/library/lux/target/jvm/modifier.lux new file mode 100644 index 000000000..109486231 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/modifier.lux @@ -0,0 +1,88 @@ +(.module: + [library + [lux #* + [abstract + ["." equivalence (#+ Equivalence)] + ["." monoid (#+ Monoid)]] + [control + ["." try] + ["<>" parser + ["<c>" code]]] + [data + [format + [".F" binary (#+ Writer)]]] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code]] + [math + ["." number (#+ hex) + ["." i64]]] + [type + abstract]]] + ["." // #_ + [encoding + ["#." unsigned]]]) + +(abstract: #export (Modifier of) + //unsigned.U2 + + (def: #export code + (-> (Modifier Any) //unsigned.U2) + (|>> :representation)) + + (implementation: #export equivalence + (All [of] (Equivalence (Modifier of))) + + (def: (= reference sample) + (\ //unsigned.equivalence = + (:representation reference) + (:representation sample)))) + + (template: (!wrap value) + (|> value + //unsigned.u2 + try.assume + :abstraction)) + + (template: (!unwrap value) + (|> value + :representation + //unsigned.value)) + + (def: #export (has? sub super) + (All [of] (-> (Modifier of) (Modifier of) Bit)) + (let [sub (!unwrap sub)] + (|> (!unwrap super) + (i64.and sub) + (\ i64.equivalence = sub)))) + + (implementation: #export monoid + (All [of] (Monoid (Modifier of))) + + (def: identity + (!wrap (hex "0000"))) + + (def: (compose left right) + (!wrap (i64.or (!unwrap left) (!unwrap right))))) + + (def: #export empty + Modifier + (\ ..monoid identity)) + + (def: #export writer + (All [of] (Writer (Modifier of))) + (|>> :representation //unsigned.writer/2)) + + (def: modifier + (-> Nat Modifier) + (|>> !wrap)) + ) + +(syntax: #export (modifiers: ofT {options (<>.many <c>.any)}) + (with_gensyms [g!modifier g!code] + (wrap (list (` (template [(~ g!code) (~ g!modifier)] + [(def: (~' #export) (~ g!modifier) + (..Modifier (~ ofT)) + ((~! ..modifier) ((~! number.hex) (~ g!code))))] + + (~+ options))))))) diff --git a/stdlib/source/library/lux/target/jvm/modifier/inner.lux b/stdlib/source/library/lux/target/jvm/modifier/inner.lux new file mode 100644 index 000000000..fc9bc982c --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/modifier/inner.lux @@ -0,0 +1,21 @@ +(.module: + [library + [lux (#- static) + [type + abstract]]] + [// (#+ modifiers:)]) + +(abstract: #export Inner Any) + +(modifiers: Inner + ["0001" public] + ["0002" private] + ["0004" protected] + ["0008" static] + ["0010" final] + ["0200" interface] + ["0400" abstract] + ["1000" synthetic] + ["2000" annotation] + ["4000" enum] + ) diff --git a/stdlib/source/library/lux/target/jvm/reflection.lux b/stdlib/source/library/lux/target/jvm/reflection.lux new file mode 100644 index 000000000..e2297f313 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/reflection.lux @@ -0,0 +1,382 @@ +(.module: + [library + [lux (#- type) + ["." ffi (#+ import:)] + ["." type] + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + [parser + ["<t>" text]]] + [data + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." list ("#\." fold functor)] + ["." array] + ["." dictionary]]] + [math + [number + ["n" nat]]]]] + ["." // #_ + [encoding + ["#." name (#+ External)]] + ["/" type + [category (#+ Void Value Return Method Primitive Object Class Array Parameter)] + ["#." lux (#+ Mapping)] + ["#." descriptor] + ["#." reflection] + ["#." parser]]]) + +(import: java/lang/String) + +(import: java/lang/Object + ["#::." + (toString [] java/lang/String) + (getClass [] (java/lang/Class java/lang/Object))]) + +(import: java/lang/reflect/Type + ["#::." + (getTypeName [] java/lang/String)]) + +(import: java/lang/reflect/GenericArrayType + ["#::." + (getGenericComponentType [] java/lang/reflect/Type)]) + +(import: java/lang/reflect/ParameterizedType + ["#::." + (getRawType [] java/lang/reflect/Type) + (getActualTypeArguments [] [java/lang/reflect/Type])]) + +(import: (java/lang/reflect/TypeVariable d) + ["#::." + (getName [] java/lang/String) + (getBounds [] [java/lang/reflect/Type])]) + +(import: (java/lang/reflect/WildcardType d) + ["#::." + (getLowerBounds [] [java/lang/reflect/Type]) + (getUpperBounds [] [java/lang/reflect/Type])]) + +(import: java/lang/reflect/Modifier + ["#::." + (#static isStatic [int] boolean) + (#static isFinal [int] boolean) + (#static isInterface [int] boolean) + (#static isAbstract [int] boolean)]) + +(import: java/lang/annotation/Annotation) + +(import: java/lang/Deprecated) + +(import: java/lang/reflect/Field + ["#::." + (getDeclaringClass [] (java/lang/Class java/lang/Object)) + (getModifiers [] int) + (getGenericType [] java/lang/reflect/Type) + (getDeclaredAnnotations [] [java/lang/annotation/Annotation])]) + +(import: java/lang/reflect/Method + ["#::." + (getName [] java/lang/String) + (getModifiers [] int) + (getDeclaringClass [] (java/lang/Class java/lang/Object)) + (getTypeParameters [] [(java/lang/reflect/TypeVariable java/lang/reflect/Method)]) + (getGenericParameterTypes [] [java/lang/reflect/Type]) + (getGenericReturnType [] java/lang/reflect/Type) + (getGenericExceptionTypes [] [java/lang/reflect/Type])]) + +(import: (java/lang/reflect/Constructor c) + ["#::." + (getModifiers [] int) + (getDeclaringClass [] (java/lang/Class c)) + (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/reflect/Constructor c))]) + (getGenericParameterTypes [] [java/lang/reflect/Type]) + (getGenericExceptionTypes [] [java/lang/reflect/Type])]) + +(import: (java/lang/Class c) + ["#::." + (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object)) + (getName [] java/lang/String) + (getModifiers [] int) + (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean) + (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/Class c))]) + (getGenericInterfaces [] [java/lang/reflect/Type]) + (getGenericSuperclass [] #? java/lang/reflect/Type) + (getDeclaredField [java/lang/String] #try java/lang/reflect/Field) + (getConstructors [] [(java/lang/reflect/Constructor java/lang/Object)]) + (getDeclaredMethods [] [java/lang/reflect/Method])]) + +(exception: #export (unknown_class {class External}) + (exception.report + ["Class" (%.text class)])) + +(template [<name>] + [(exception: #export (<name> {jvm_type java/lang/reflect/Type}) + (exception.report + ["Type" (java/lang/reflect/Type::getTypeName jvm_type)] + ["Class" (|> jvm_type java/lang/Object::getClass java/lang/Object::toString)]))] + + [not_a_class] + [cannot_convert_to_a_lux_type] + ) + +(def: #export (load name) + (-> External (Try (java/lang/Class java/lang/Object))) + (case (java/lang/Class::forName name) + (#try.Success class) + (#try.Success class) + + (#try.Failure _) + (exception.throw ..unknown_class name))) + +(def: #export (sub? super sub) + (-> External External (Try Bit)) + (do try.monad + [super (..load super) + sub (..load sub)] + (wrap (java/lang/Class::isAssignableFrom sub super)))) + +(def: (class' parameter reflection) + (-> (-> java/lang/reflect/Type (Try (/.Type Parameter))) + java/lang/reflect/Type + (Try (/.Type Class))) + (<| (case (ffi.check java/lang/Class reflection) + (#.Some class) + (let [class_name (|> class + (:as (java/lang/Class java/lang/Object)) + java/lang/Class::getName)] + (`` (if (or (~~ (template [<reflection>] + [(text\= (/reflection.reflection <reflection>) + class_name)] + + [/reflection.boolean] + [/reflection.byte] + [/reflection.short] + [/reflection.int] + [/reflection.long] + [/reflection.float] + [/reflection.double] + [/reflection.char])) + (text.starts_with? /descriptor.array_prefix class_name)) + (exception.throw ..not_a_class reflection) + (#try.Success (/.class class_name (list)))))) + _) + (case (ffi.check java/lang/reflect/ParameterizedType reflection) + (#.Some reflection) + (let [raw (java/lang/reflect/ParameterizedType::getRawType reflection)] + (case (ffi.check java/lang/Class raw) + (#.Some raw) + (do {! try.monad} + [paramsT (|> reflection + java/lang/reflect/ParameterizedType::getActualTypeArguments + array.to_list + (monad.map ! parameter))] + (wrap (/.class (|> raw + (:as (java/lang/Class java/lang/Object)) + java/lang/Class::getName) + paramsT))) + + _ + (exception.throw ..not_a_class raw))) + _) + ## else + (exception.throw ..cannot_convert_to_a_lux_type reflection))) + +(def: #export (parameter reflection) + (-> java/lang/reflect/Type (Try (/.Type Parameter))) + (<| (case (ffi.check java/lang/reflect/TypeVariable reflection) + (#.Some reflection) + (#try.Success (/.var (java/lang/reflect/TypeVariable::getName reflection))) + _) + (case (ffi.check java/lang/reflect/WildcardType reflection) + (#.Some reflection) + ## TODO: Instead of having single lower/upper bounds, should + ## allow for multiple ones. + (case [(array.read 0 (java/lang/reflect/WildcardType::getLowerBounds reflection)) + (array.read 0 (java/lang/reflect/WildcardType::getUpperBounds reflection))] + (^template [<pattern> <kind>] + [<pattern> + (case (ffi.check java/lang/reflect/GenericArrayType bound) + (#.Some _) + ## TODO: Array bounds should not be "erased" as they + ## are right now. + (#try.Success /.wildcard) + + _ + (\ try.monad map <kind> (..class' parameter bound)))]) + ([[_ (#.Some bound)] /.upper] + [[(#.Some bound) _] /.lower]) + + _ + (#try.Success /.wildcard)) + _) + (..class' parameter reflection))) + +(def: #export class + (-> java/lang/reflect/Type + (Try (/.Type Class))) + (..class' ..parameter)) + +(def: #export (type reflection) + (-> java/lang/reflect/Type (Try (/.Type Value))) + (<| (case (ffi.check java/lang/Class reflection) + (#.Some reflection) + (let [class_name (|> reflection + (:as (java/lang/Class java/lang/Object)) + java/lang/Class::getName)] + (`` (cond (~~ (template [<reflection> <type>] + [(text\= (/reflection.reflection <reflection>) + class_name) + (#try.Success <type>)] + + [/reflection.boolean /.boolean] + [/reflection.byte /.byte] + [/reflection.short /.short] + [/reflection.int /.int] + [/reflection.long /.long] + [/reflection.float /.float] + [/reflection.double /.double] + [/reflection.char /.char])) + (if (text.starts_with? /descriptor.array_prefix class_name) + (<t>.run /parser.value (|> class_name //name.internal //name.read)) + (#try.Success (/.class class_name (list))))))) + _) + (case (ffi.check java/lang/reflect/GenericArrayType reflection) + (#.Some reflection) + (|> reflection + java/lang/reflect/GenericArrayType::getGenericComponentType + type + (\ try.monad map /.array)) + _) + ## else + (..parameter reflection))) + +(def: #export (return reflection) + (-> java/lang/reflect/Type (Try (/.Type Return))) + (with_expansions [<else> (as_is (..type reflection))] + (case (ffi.check java/lang/Class reflection) + (#.Some class) + (let [class_name (|> reflection + (:as (java/lang/Class java/lang/Object)) + java/lang/Class::getName)] + (if (text\= (/reflection.reflection /reflection.void) + class_name) + (#try.Success /.void) + <else>)) + + #.None + <else>))) + +(exception: #export (cannot_correspond {class (java/lang/Class java/lang/Object)} + {type Type}) + (exception.report + ["Class" (java/lang/Object::toString class)] + ["Type" (%.type type)])) + +(exception: #export (type_parameter_mismatch {expected Nat} + {actual Nat} + {class (java/lang/Class java/lang/Object)} + {type Type}) + (exception.report + ["Expected" (%.nat expected)] + ["Actual" (%.nat actual)] + ["Class" (java/lang/Object::toString class)] + ["Type" (%.type type)])) + +(exception: #export (non_jvm_type {type Type}) + (exception.report + ["Type" (%.type type)])) + +(def: #export (correspond class type) + (-> (java/lang/Class java/lang/Object) Type (Try Mapping)) + (case type + (#.Primitive name params) + (let [class_name (java/lang/Class::getName class) + class_params (array.to_list (java/lang/Class::getTypeParameters class)) + num_class_params (list.size class_params) + num_type_params (list.size params)] + (if (text\= class_name name) + (if (n.= num_class_params num_type_params) + (|> params + (list.zip/2 (list\map (|>> java/lang/reflect/TypeVariable::getName) + class_params)) + (list\fold (function (_ [name paramT] mapping) + (dictionary.put name paramT mapping)) + /lux.fresh) + #try.Success) + (exception.throw ..type_parameter_mismatch [num_class_params num_type_params class type])) + (exception.throw ..cannot_correspond [class type]))) + + (#.Named name anonymousT) + (correspond class anonymousT) + + (#.Apply inputT abstractionT) + (case (type.apply (list inputT) abstractionT) + (#.Some outputT) + (correspond class outputT) + + #.None + (exception.throw ..non_jvm_type [type])) + + _ + (exception.throw ..non_jvm_type [type]))) + +(exception: #export (mistaken_field_owner {field java/lang/reflect/Field} + {owner (java/lang/Class java/lang/Object)} + {target (java/lang/Class java/lang/Object)}) + (exception.report + ["Field" (java/lang/Object::toString field)] + ["Owner" (java/lang/Object::toString owner)] + ["Target" (java/lang/Object::toString target)])) + +(template [<name>] + [(exception: #export (<name> {field Text} + {class (java/lang/Class java/lang/Object)}) + (exception.report + ["Field" (%.text field)] + ["Class" (java/lang/Object::toString class)]))] + + [unknown_field] + [not_a_static_field] + [not_a_virtual_field] + ) + +(def: #export (field field target) + (-> Text (java/lang/Class java/lang/Object) (Try java/lang/reflect/Field)) + (case (java/lang/Class::getDeclaredField field target) + (#try.Success field) + (let [owner (java/lang/reflect/Field::getDeclaringClass field)] + (if (is? owner target) + (#try.Success field) + (exception.throw ..mistaken_field_owner [field owner target]))) + + (#try.Failure _) + (exception.throw ..unknown_field [field target]))) + +(def: #export deprecated? + (-> (array.Array java/lang/annotation/Annotation) Bit) + (|>> array.to_list + (list.all (|>> (ffi.check java/lang/Deprecated))) + list.empty? + not)) + +(template [<name> <exception> <then?> <else?>] + [(def: #export (<name> field class) + (-> Text (java/lang/Class java/lang/Object) (Try [Bit Bit (/.Type Value)])) + (do {! try.monad} + [fieldJ (..field field class) + #let [modifiers (java/lang/reflect/Field::getModifiers fieldJ)]] + (case (java/lang/reflect/Modifier::isStatic modifiers) + <then?> (|> fieldJ + java/lang/reflect/Field::getGenericType + ..type + (\ ! map (|>> [(java/lang/reflect/Modifier::isFinal modifiers) + (..deprecated? (java/lang/reflect/Field::getDeclaredAnnotations fieldJ))]))) + <else?> (exception.throw <exception> [field class]))))] + + [static_field ..not_a_static_field #1 #0] + [virtual_field ..not_a_virtual_field #0 #1] + ) diff --git a/stdlib/source/library/lux/target/jvm/type.lux b/stdlib/source/library/lux/target/jvm/type.lux new file mode 100644 index 000000000..e11ef5c99 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/type.lux @@ -0,0 +1,205 @@ +(.module: + [library + [lux (#- Type int char) + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] + [data + ["." maybe] + ["." text + ["%" format (#+ Format)]] + [collection + ["." list ("#\." functor)]]] + [math + [number + ["n" nat]]] + [type + abstract]]] + ["." // #_ + [encoding + ["#." name (#+ External)]]] + ["." / #_ + [category (#+ Void Value' Value Return' Return Method Primitive Object Class Array Var Parameter Declaration)] + ["#." signature (#+ Signature)] + ["#." descriptor (#+ Descriptor)] + ["#." reflection (#+ Reflection)]]) + +(abstract: #export (Type category) + [(Signature category) (Descriptor category) (Reflection category)] + + (type: #export Argument + [Text (Type Value)]) + + (type: #export (Typed a) + [(Type Value) a]) + + (type: #export Constraint + {#name Text + #super_class (Type Class) + #super_interfaces (List (Type Class))}) + + (template [<name> <style>] + [(def: #export (<name> type) + (All [category] (-> (Type category) (<style> category))) + (let [[signature descriptor reflection] (:representation type)] + <name>))] + + [signature Signature] + [descriptor Descriptor] + ) + + (def: #export (reflection type) + (All [category] + (-> (Type (<| Return' Value' category)) + (Reflection (<| Return' Value' category)))) + (let [[signature descriptor reflection] (:representation type)] + reflection)) + + (template [<category> <name> <signature> <descriptor> <reflection>] + [(def: #export <name> + (Type <category>) + (:abstraction [<signature> <descriptor> <reflection>]))] + + [Void void /signature.void /descriptor.void /reflection.void] + [Primitive boolean /signature.boolean /descriptor.boolean /reflection.boolean] + [Primitive byte /signature.byte /descriptor.byte /reflection.byte] + [Primitive short /signature.short /descriptor.short /reflection.short] + [Primitive int /signature.int /descriptor.int /reflection.int] + [Primitive long /signature.long /descriptor.long /reflection.long] + [Primitive float /signature.float /descriptor.float /reflection.float] + [Primitive double /signature.double /descriptor.double /reflection.double] + [Primitive char /signature.char /descriptor.char /reflection.char] + ) + + (def: #export (array type) + (-> (Type Value) (Type Array)) + (:abstraction + [(/signature.array (..signature type)) + (/descriptor.array (..descriptor type)) + (/reflection.array (..reflection type))])) + + (def: #export (class name parameters) + (-> External (List (Type Parameter)) (Type Class)) + (:abstraction + [(/signature.class name (list\map ..signature parameters)) + (/descriptor.class name) + (/reflection.class name)])) + + (def: #export (declaration name variables) + (-> External (List (Type Var)) (Type Declaration)) + (:abstraction + [(/signature.declaration name (list\map ..signature variables)) + (/descriptor.declaration name) + (/reflection.declaration name)])) + + (def: #export (as_class type) + (-> (Type Declaration) (Type Class)) + (:abstraction + (let [[signature descriptor reflection] (:representation type)] + [(/signature.as_class signature) + (/descriptor.as_class descriptor) + (/reflection.as_class reflection)]))) + + (def: #export wildcard + (Type Parameter) + (:abstraction + [/signature.wildcard + /descriptor.wildcard + /reflection.wildcard])) + + (def: #export (var name) + (-> Text (Type Var)) + (:abstraction + [(/signature.var name) + /descriptor.var + /reflection.var])) + + (def: #export (lower bound) + (-> (Type Class) (Type Parameter)) + (:abstraction + (let [[signature descriptor reflection] (:representation bound)] + [(/signature.lower signature) + (/descriptor.lower descriptor) + (/reflection.lower reflection)]))) + + (def: #export (upper bound) + (-> (Type Class) (Type Parameter)) + (:abstraction + (let [[signature descriptor reflection] (:representation bound)] + [(/signature.upper signature) + (/descriptor.upper descriptor) + (/reflection.upper reflection)]))) + + (def: #export (method [inputs output exceptions]) + (-> [(List (Type Value)) + (Type Return) + (List (Type Class))] + (Type Method)) + (:abstraction + [(/signature.method [(list\map ..signature inputs) + (..signature output) + (list\map ..signature exceptions)]) + (/descriptor.method [(list\map ..descriptor inputs) + (..descriptor output)]) + (:assume ..void)])) + + (implementation: #export equivalence + (All [category] (Equivalence (Type category))) + + (def: (= parameter subject) + (\ /signature.equivalence = + (..signature parameter) + (..signature subject)))) + + (implementation: #export hash + (All [category] (Hash (Type category))) + + (def: &equivalence ..equivalence) + (def: hash (|>> ..signature (\ /signature.hash hash)))) + + (def: #export (primitive? type) + (-> (Type Value) (Either (Type Object) + (Type Primitive))) + (if (`` (or (~~ (template [<type>] + [(\ ..equivalence = (: (Type Value) <type>) type)] + + [..boolean] + [..byte] + [..short] + [..int] + [..long] + [..float] + [..double] + [..char])))) + (|> type (:as (Type Primitive)) #.Right) + (|> type (:as (Type Object)) #.Left))) + + (def: #export (void? type) + (-> (Type Return) (Either (Type Value) + (Type Void))) + (if (`` (or (~~ (template [<type>] + [(\ ..equivalence = (: (Type Return) <type>) type)] + + [..void])))) + (|> type (:as (Type Void)) #.Right) + (|> type (:as (Type Value)) #.Left))) + ) + +(def: #export (class? type) + (-> (Type Value) (Maybe External)) + (let [repr (|> type ..descriptor /descriptor.descriptor)] + (if (and (text.starts_with? /descriptor.class_prefix repr) + (text.ends_with? /descriptor.class_suffix repr)) + (let [prefix_size (text.size /descriptor.class_prefix) + suffix_size (text.size /descriptor.class_suffix) + name_size (|> (text.size repr) + (n.- prefix_size) + (n.- suffix_size))] + (|> repr + (text.clip prefix_size name_size) + (\ maybe.monad map (|>> //name.internal //name.external)))) + #.None))) + +(def: #export format + (All [a] (Format (Type a))) + (|>> ..signature /signature.signature)) diff --git a/stdlib/source/library/lux/target/jvm/type/alias.lux b/stdlib/source/library/lux/target/jvm/type/alias.lux new file mode 100644 index 000000000..56ffbe127 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/type/alias.lux @@ -0,0 +1,116 @@ +(.module: + [library + [lux (#- Type int char type primitive) + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["." exception (#+ exception:)] + ["<>" parser + ["<t>" text (#+ Parser)]]] + [data + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary (#+ Dictionary)]]]]] + ["." // (#+ Type) + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] + ["#." descriptor] + ["#." signature (#+ Signature)] + ["#." reflection] + ["#." parser] + ["/#" // #_ + [encoding + ["#." name]]]]) + +(type: #export Aliasing + (Dictionary Text Text)) + +(def: #export fresh + Aliasing + (dictionary.new text.hash)) + +(def: (var aliasing) + (-> Aliasing (Parser (Type Var))) + (do <>.monad + [var //parser.var'] + (wrap (|> aliasing + (dictionary.get var) + (maybe.default var) + //.var)))) + +(def: (class parameter) + (-> (Parser (Type Parameter)) (Parser (Type Class))) + (|> (do <>.monad + [name //parser.class_name + parameters (|> (<>.some parameter) + (<>.after (<t>.this //signature.parameters_start)) + (<>.before (<t>.this //signature.parameters_end)) + (<>.default (list)))] + (wrap (//.class name parameters))) + (<>.after (<t>.this //descriptor.class_prefix)) + (<>.before (<t>.this //descriptor.class_suffix)))) + +(template [<name> <prefix> <bound> <constructor>] + [(def: <name> + (-> (Parser (Type Class)) (Parser (Type Parameter))) + (|>> (<>.after (<t>.this <prefix>)) + (\ <>.monad map <bound>)))] + + [lower //signature.lower_prefix //.lower ..Lower] + [upper //signature.upper_prefix //.upper ..Upper] + ) + +(def: (parameter aliasing) + (-> Aliasing (Parser (Type Parameter))) + (<>.rec + (function (_ parameter) + (let [class (..class parameter)] + ($_ <>.either + (..var aliasing) + //parser.wildcard + (..lower class) + (..upper class) + class + ))))) + +(def: (value aliasing) + (-> Aliasing (Parser (Type Value))) + (<>.rec + (function (_ value) + ($_ <>.either + //parser.primitive + (parameter aliasing) + (//parser.array' value) + )))) + +(def: (inputs aliasing) + (-> Aliasing (Parser (List (Type Value)))) + (|> (<>.some (..value aliasing)) + (<>.after (<t>.this //signature.arguments_start)) + (<>.before (<t>.this //signature.arguments_end)))) + +(def: (return aliasing) + (-> Aliasing (Parser (Type Return))) + ($_ <>.either + //parser.void + (..value aliasing) + )) + +(def: (exception aliasing) + (-> Aliasing (Parser (Type Class))) + (|> (..class (..parameter aliasing)) + (<>.after (<t>.this //signature.exception_prefix)))) + +(def: #export (method aliasing type) + (-> Aliasing (Type Method) (Type Method)) + (|> type + //.signature + //signature.signature + (<t>.run (do <>.monad + [inputs (..inputs aliasing) + return (..return aliasing) + exceptions (<>.some (..exception aliasing))] + (wrap (//.method [inputs return exceptions])))) + try.assume)) diff --git a/stdlib/source/library/lux/target/jvm/type/box.lux b/stdlib/source/library/lux/target/jvm/type/box.lux new file mode 100644 index 000000000..9479ef218 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/type/box.lux @@ -0,0 +1,19 @@ +(.module: + [library + [lux (#- int char)]] + [/// + [encoding + [name (#+ External)]]]) + +(template [<name> <box>] + [(def: #export <name> External <box>)] + + [boolean "java.lang.Boolean"] + [byte "java.lang.Byte"] + [short "java.lang.Short"] + [int "java.lang.Integer"] + [long "java.lang.Long"] + [float "java.lang.Float"] + [double "java.lang.Double"] + [char "java.lang.Character"] + ) diff --git a/stdlib/source/library/lux/target/jvm/type/category.lux b/stdlib/source/library/lux/target/jvm/type/category.lux new file mode 100644 index 000000000..f6c17a280 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/type/category.lux @@ -0,0 +1,36 @@ +(.module: + [library + [lux #* + [macro + ["." template]] + [type + abstract]]]) + +(abstract: #export Void' Any) +(abstract: #export (Value' kind) Any) +(abstract: #export (Return' kind) Any) +(abstract: #export Method Any) + +(type: #export Return (<| Return' Any)) +(type: #export Value (<| Return' Value' Any)) +(type: #export Void (<| Return' Void')) + +(abstract: #export (Object' brand) Any) +(type: #export Object (<| Return' Value' Object' Any)) + +(abstract: #export (Parameter' brand) Any) +(type: #export Parameter (<| Return' Value' Object' Parameter' Any)) + +(template [<parents> <child>] + [(with_expansions [<raw> (template.identifier [<child> "'"])] + (abstract: #export <raw> Any) + (type: #export <child> + (`` (<| Return' Value' (~~ (template.splice <parents>)) <raw>))))] + + [[] Primitive] + [[Object' Parameter'] Var] + [[Object' Parameter'] Class] + [[Object'] Array] + ) + +(abstract: #export Declaration Any) diff --git a/stdlib/source/library/lux/target/jvm/type/descriptor.lux b/stdlib/source/library/lux/target/jvm/type/descriptor.lux new file mode 100644 index 000000000..2cdbeb6ee --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/type/descriptor.lux @@ -0,0 +1,123 @@ +(.module: + [library + [lux (#- int char) + [abstract + [equivalence (#+ Equivalence)]] + [data + ["." maybe] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)]]] + [math + [number + ["n" nat]]] + [type + abstract]]] + ["." // #_ + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)] + ["/#" // #_ + [encoding + ["#." name (#+ Internal External)]]]]) + +(abstract: #export (Descriptor category) + Text + + (def: #export descriptor + (-> (Descriptor Any) Text) + (|>> :representation)) + + (template [<sigil> <category> <name>] + [(def: #export <name> + (Descriptor <category>) + (:abstraction <sigil>))] + + ["V" Void void] + ["Z" Primitive boolean] + ["B" Primitive byte] + ["S" Primitive short] + ["I" Primitive int] + ["J" Primitive long] + ["F" Primitive float] + ["D" Primitive double] + ["C" Primitive char] + ) + + (def: #export class_prefix "L") + (def: #export class_suffix ";") + + (def: #export class + (-> External (Descriptor Class)) + (|>> ///name.internal + ///name.read + (text.enclose [..class_prefix ..class_suffix]) + :abstraction)) + + (def: #export (declaration name) + (-> External (Descriptor Declaration)) + (:transmutation (..class name))) + + (def: #export as_class + (-> (Descriptor Declaration) (Descriptor Class)) + (|>> :transmutation)) + + (template [<name> <category>] + [(def: #export <name> + (Descriptor <category>) + (:transmutation + (..class "java.lang.Object")))] + + [var Var] + [wildcard Parameter] + ) + + (def: #export (lower descriptor) + (-> (Descriptor Class) (Descriptor Parameter)) + ..wildcard) + + (def: #export upper + (-> (Descriptor Class) (Descriptor Parameter)) + (|>> :transmutation)) + + (def: #export array_prefix "[") + + (def: #export array + (-> (Descriptor Value) + (Descriptor Array)) + (|>> :representation + (format ..array_prefix) + :abstraction)) + + (def: #export (method [inputs output]) + (-> [(List (Descriptor Value)) + (Descriptor Return)] + (Descriptor Method)) + (:abstraction + (format (|> inputs + (list\map ..descriptor) + (text.join_with "") + (text.enclose ["(" ")"])) + (:representation output)))) + + (implementation: #export equivalence + (All [category] (Equivalence (Descriptor category))) + + (def: (= parameter subject) + (text\= (:representation parameter) (:representation subject)))) + + (def: #export class_name + (-> (Descriptor Object) Internal) + (let [prefix_size (text.size ..class_prefix) + suffix_size (text.size ..class_suffix)] + (function (_ descriptor) + (let [repr (:representation descriptor)] + (if (text.starts_with? ..array_prefix repr) + (///name.internal repr) + (|> repr + (text.clip prefix_size + (|> (text.size repr) + (n.- prefix_size) + (n.- suffix_size))) + (\ maybe.monad map ///name.internal) + maybe.assume)))))) + ) diff --git a/stdlib/source/library/lux/target/jvm/type/lux.lux b/stdlib/source/library/lux/target/jvm/type/lux.lux new file mode 100644 index 000000000..45fd34c8d --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/type/lux.lux @@ -0,0 +1,189 @@ +(.module: + [library + [lux (#- int char type primitive) + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["." exception (#+ exception:)] + ["<>" parser ("#\." monad) + ["<t>" text (#+ Parser)]]] + [data + ["." product] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." array] + ["." dictionary (#+ Dictionary)]]] + [type + abstract + ["." check (#+ Check) ("#\." monad)]]]] + ["." // + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] + ["#." descriptor] + ["#." signature] + ["#." reflection] + ["#." parser] + ["/#" // #_ + [encoding + ["#." name]]]]) + +(template [<name>] + [(abstract: #export (<name> class) Any)] + + [Lower] [Upper] + ) + +(type: #export Mapping + (Dictionary Text Type)) + +(def: #export fresh + Mapping + (dictionary.new text.hash)) + +(exception: #export (unknown_var {var Text}) + (exception.report + ["Var" (%.text var)])) + +(def: void + (Parser (Check Type)) + (<>.after //parser.void + (<>\wrap (check\wrap .Any)))) + +(template [<name> <parser> <reflection>] + [(def: <name> + (Parser (Check Type)) + (<>.after <parser> + (<>\wrap (check\wrap (#.Primitive (//reflection.reflection <reflection>) #.Nil)))))] + + [boolean //parser.boolean //reflection.boolean] + [byte //parser.byte //reflection.byte] + [short //parser.short //reflection.short] + [int //parser.int //reflection.int] + [long //parser.long //reflection.long] + [float //parser.float //reflection.float] + [double //parser.double //reflection.double] + [char //parser.char //reflection.char] + ) + +(def: primitive + (Parser (Check Type)) + ($_ <>.either + ..boolean + ..byte + ..short + ..int + ..long + ..float + ..double + ..char + )) + +(def: wildcard + (Parser (Check Type)) + (<>.after //parser.wildcard + (<>\wrap (check\map product.right + check.existential)))) + +(def: (var mapping) + (-> Mapping (Parser (Check Type))) + (do <>.monad + [var //parser.var'] + (wrap (case (dictionary.get var mapping) + #.None + (check.throw ..unknown_var [var]) + + (#.Some type) + (check\wrap type))))) + +(def: (class' parameter) + (-> (Parser (Check Type)) (Parser (Check Type))) + (|> (do <>.monad + [name //parser.class_name + parameters (|> (<>.some parameter) + (<>.after (<t>.this //signature.parameters_start)) + (<>.before (<t>.this //signature.parameters_end)) + (<>.default (list)))] + (wrap (do {! check.monad} + [parameters (monad.seq ! parameters)] + (wrap (#.Primitive name parameters))))) + (<>.after (<t>.this //descriptor.class_prefix)) + (<>.before (<t>.this //descriptor.class_suffix)))) + +(template [<name> <prefix> <constructor>] + [(def: <name> + (-> (Parser (Check Type)) (Parser (Check Type))) + (|> (<>.after (<t>.this <prefix>)) + ## TODO: Re-enable Lower and Upper, instead of using the simplified limit. + ## (<>\map (check\map (|>> <ctor> .type))) + ))] + + [lower //signature.lower_prefix ..Lower] + [upper //signature.upper_prefix ..Upper] + ) + +(def: (parameter mapping) + (-> Mapping (Parser (Check Type))) + (<>.rec + (function (_ parameter) + (let [class (..class' parameter)] + ($_ <>.either + (..var mapping) + ..wildcard + (..lower class) + (..upper class) + class + ))))) + +(def: #export class + (-> Mapping (Parser (Check Type))) + (|>> ..parameter ..class')) + +(def: array + (-> (Parser (Check Type)) (Parser (Check Type))) + (|>> (<>\map (check\map (function (_ elementT) + (case elementT + (#.Primitive name #.Nil) + (if (`` (or (~~ (template [<reflection>] + [(text\= (//reflection.reflection <reflection>) name)] + + [//reflection.boolean] + [//reflection.byte] + [//reflection.short] + [//reflection.int] + [//reflection.long] + [//reflection.float] + [//reflection.double] + [//reflection.char])))) + (#.Primitive (|> name //reflection.class //reflection.array //reflection.reflection) #.Nil) + (|> elementT array.Array .type)) + + _ + (|> elementT array.Array .type))))) + (<>.after (<t>.this //descriptor.array_prefix)))) + +(def: #export (type mapping) + (-> Mapping (Parser (Check Type))) + (<>.rec + (function (_ type) + ($_ <>.either + ..primitive + (parameter mapping) + (..array type) + )))) + +(def: #export (return mapping) + (-> Mapping (Parser (Check Type))) + ($_ <>.either + ..void + (..type mapping) + )) + +(def: #export (check operation input) + (All [a] (-> (Parser (Check a)) Text (Check a))) + (case (<t>.run operation input) + (#try.Success check) + check + + (#try.Failure error) + (check.fail error))) diff --git a/stdlib/source/library/lux/target/jvm/type/parser.lux b/stdlib/source/library/lux/target/jvm/type/parser.lux new file mode 100644 index 000000000..5b9a3e1af --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/type/parser.lux @@ -0,0 +1,253 @@ +(.module: + [library + [lux (#- Type int char primitive) + [abstract + [monad (#+ do)]] + [control + ["." try] + ["." function] + ["<>" parser ("#\." monad) + ["<t>" text (#+ Parser)]]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list]]]]] + ["." // (#+ Type) + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)] + ["#." signature] + ["#." descriptor] + ["." // #_ + [encoding + ["#." name (#+ External)]]]]) + +(template [<category> <name> <signature> <type>] + [(def: #export <name> + (Parser (Type <category>)) + (<>.after (<t>.this (//signature.signature <signature>)) + (<>\wrap <type>)))] + + [Void void //signature.void //.void] + [Primitive boolean //signature.boolean //.boolean] + [Primitive byte //signature.byte //.byte] + [Primitive short //signature.short //.short] + [Primitive int //signature.int //.int] + [Primitive long //signature.long //.long] + [Primitive float //signature.float //.float] + [Primitive double //signature.double //.double] + [Primitive char //signature.char //.char] + [Parameter wildcard //signature.wildcard //.wildcard] + ) + +(def: #export primitive + (Parser (Type Primitive)) + ($_ <>.either + ..boolean + ..byte + ..short + ..int + ..long + ..float + ..double + ..char + )) + +(def: var/head + (format "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "_")) + +(def: var/tail + (format var/head + "0123456789$")) + +(def: class/set + (format var/tail //name.internal_separator)) + +(template [<type> <name> <head> <tail> <adapter>] + [(def: #export <name> + (Parser <type>) + (\ <>.functor map <adapter> + (<t>.slice (<t>.and! (<t>.one_of! <head>) + (<t>.some! (<t>.one_of! <tail>))))))] + + [External class_name class/set class/set (|>> //name.internal //name.external)] + [Text var_name var/head var/tail function.identity] + ) + +(def: #export var' + (Parser Text) + (|> ..var_name + (<>.after (<t>.this //signature.var_prefix)) + (<>.before (<t>.this //descriptor.class_suffix)))) + +(def: #export var + (Parser (Type Var)) + (<>\map //.var ..var')) + +(def: #export var? + (-> (Type Value) (Maybe Text)) + (|>> //.signature + //signature.signature + (<t>.run ..var') + try.to_maybe)) + +(def: #export name + (-> (Type Var) Text) + (|>> //.signature + //signature.signature + (<t>.run ..var') + try.assume)) + +(template [<name> <prefix> <constructor>] + [(def: <name> + (-> (Parser (Type Class)) (Parser (Type Parameter))) + (|>> (<>.after (<t>.this <prefix>)) + (<>\map <constructor>)))] + + [lower //signature.lower_prefix //.lower] + [upper //signature.upper_prefix //.upper] + ) + +(def: (class'' parameter) + (-> (Parser (Type Parameter)) (Parser [External (List (Type Parameter))])) + (|> (do <>.monad + [name ..class_name + parameters (|> (<>.some parameter) + (<>.after (<t>.this //signature.parameters_start)) + (<>.before (<t>.this //signature.parameters_end)) + (<>.default (list)))] + (wrap [name parameters])) + (<>.after (<t>.this //descriptor.class_prefix)) + (<>.before (<t>.this //descriptor.class_suffix)))) + +(def: class' + (-> (Parser (Type Parameter)) (Parser (Type Class))) + (|>> ..class'' + (\ <>.monad map (product.uncurry //.class)))) + +(def: #export parameter + (Parser (Type Parameter)) + (<>.rec + (function (_ parameter) + (let [class (..class' parameter)] + ($_ <>.either + ..var + ..wildcard + (..lower class) + (..upper class) + class + ))))) + +(def: #export array' + (-> (Parser (Type Value)) (Parser (Type Array))) + (|>> (<>.after (<t>.this //descriptor.array_prefix)) + (<>\map //.array))) + +(def: #export class + (Parser (Type Class)) + (..class' ..parameter)) + +(template [<name> <prefix> <constructor>] + [(def: #export <name> + (-> (Type Value) (Maybe (Type Class))) + (|>> //.signature + //signature.signature + (<t>.run (<>.after (<t>.this <prefix>) ..class)) + try.to_maybe))] + + [lower? //signature.lower_prefix //.lower] + [upper? //signature.upper_prefix //.upper] + ) + +(def: #export read_class + (-> (Type Class) [External (List (Type Parameter))]) + (|>> //.signature + //signature.signature + (<t>.run (..class'' ..parameter)) + try.assume)) + +(def: #export value + (Parser (Type Value)) + (<>.rec + (function (_ value) + ($_ <>.either + ..primitive + ..parameter + (..array' value) + )))) + +(def: #export array + (Parser (Type Array)) + (..array' ..value)) + +(def: #export object + (Parser (Type Object)) + ($_ <>.either + ..class + ..array)) + +(def: inputs + (|> (<>.some ..value) + (<>.after (<t>.this //signature.arguments_start)) + (<>.before (<t>.this //signature.arguments_end)))) + +(def: #export return + (Parser (Type Return)) + (<>.either ..void + ..value)) + +(def: exception + (Parser (Type Class)) + (|> (..class' ..parameter) + (<>.after (<t>.this //signature.exception_prefix)))) + +(def: #export method + (-> (Type Method) + [(List (Type Value)) (Type Return) (List (Type Class))]) + (let [parser (do <>.monad + [inputs ..inputs + return ..return + exceptions (<>.some ..exception)] + (wrap [inputs return exceptions]))] + (|>> //.signature + //signature.signature + (<t>.run parser) + try.assume))) + +(template [<name> <category> <parser>] + [(def: #export <name> + (-> (Type Value) (Maybe <category>)) + (|>> //.signature + //signature.signature + (<t>.run <parser>) + try.to_maybe))] + + [array? (Type Value) + (do <>.monad + [_ (<t>.this //descriptor.array_prefix)] + ..value)] + [class? [External (List (Type Parameter))] + (..class'' ..parameter)] + + [primitive? (Type Primitive) ..primitive] + [wildcard? (Type Parameter) ..wildcard] + [parameter? (Type Parameter) ..parameter] + [object? (Type Object) ..object] + ) + +(def: #export declaration + (-> (Type Declaration) [External (List (Type Var))]) + (let [declaration' (: (Parser [External (List (Type Var))]) + (|> (<>.and ..class_name + (|> (<>.some ..var) + (<>.after (<t>.this //signature.parameters_start)) + (<>.before (<t>.this //signature.parameters_end)) + (<>.default (list)))) + (<>.after (<t>.this //descriptor.class_prefix)) + (<>.before (<t>.this //descriptor.class_suffix))))] + (|>> //.signature + //signature.signature + (<t>.run declaration') + try.assume))) diff --git a/stdlib/source/library/lux/target/jvm/type/reflection.lux b/stdlib/source/library/lux/target/jvm/type/reflection.lux new file mode 100644 index 000000000..78ef5a45c --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/type/reflection.lux @@ -0,0 +1,104 @@ +(.module: + [library + [lux (#- int char) + [abstract + [equivalence (#+ Equivalence)]] + [data + ["." text ("#\." equivalence) + ["%" format (#+ format)]]] + [type + abstract]]] + ["." // #_ + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)] + ["#." descriptor] + [// + [encoding + ["#." name (#+ External)]]]]) + +(abstract: #export (Reflection category) + Text + + (def: #export reflection + (-> (Reflection Any) Text) + (|>> :representation)) + + (implementation: #export equivalence + (All [category] (Equivalence (Reflection category))) + + (def: (= parameter subject) + (text\= (:representation parameter) (:representation subject)))) + + (template [<category> <name> <reflection>] + [(def: #export <name> + (Reflection <category>) + (:abstraction <reflection>))] + + [Void void "void"] + [Primitive boolean "boolean"] + [Primitive byte "byte"] + [Primitive short "short"] + [Primitive int "int"] + [Primitive long "long"] + [Primitive float "float"] + [Primitive double "double"] + [Primitive char "char"] + ) + + (def: #export class + (-> External (Reflection Class)) + (|>> :abstraction)) + + (def: #export (declaration name) + (-> External (Reflection Declaration)) + (:transmutation (..class name))) + + (def: #export as_class + (-> (Reflection Declaration) (Reflection Class)) + (|>> :transmutation)) + + (def: #export (array element) + (-> (Reflection Value) (Reflection Array)) + (let [element' (:representation element) + elementR (`` (cond (text.starts_with? //descriptor.array_prefix element') + element' + + (~~ (template [<primitive> <descriptor>] + [(\ ..equivalence = <primitive> element) + (//descriptor.descriptor <descriptor>)] + + [..boolean //descriptor.boolean] + [..byte //descriptor.byte] + [..short //descriptor.short] + [..int //descriptor.int] + [..long //descriptor.long] + [..float //descriptor.float] + [..double //descriptor.double] + [..char //descriptor.char])) + + (|> element' + //descriptor.class + //descriptor.descriptor + (text.replace_all //name.internal_separator + //name.external_separator))))] + (|> elementR + (format //descriptor.array_prefix) + :abstraction))) + + (template [<name> <category>] + [(def: #export <name> + (Reflection <category>) + (:transmutation + (..class "java.lang.Object")))] + + [var Var] + [wildcard Parameter] + ) + + (def: #export (lower reflection) + (-> (Reflection Class) (Reflection Parameter)) + ..wildcard) + + (def: #export upper + (-> (Reflection Class) (Reflection Parameter)) + (|>> :transmutation)) + ) diff --git a/stdlib/source/library/lux/target/jvm/type/signature.lux b/stdlib/source/library/lux/target/jvm/type/signature.lux new file mode 100644 index 000000000..0b21807dd --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/type/signature.lux @@ -0,0 +1,134 @@ +(.module: + [library + [lux (#- int char) + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] + [data + ["." text ("#\." hash) + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)]]] + [type + abstract]]] + ["." // #_ + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)] + ["#." descriptor] + ["/#" // #_ + [encoding + ["#." name (#+ External)]]]]) + +(abstract: #export (Signature category) + Text + + (def: #export signature + (-> (Signature Any) Text) + (|>> :representation)) + + (template [<category> <name> <descriptor>] + [(def: #export <name> + (Signature <category>) + (:abstraction (//descriptor.descriptor <descriptor>)))] + + [Void void //descriptor.void] + [Primitive boolean //descriptor.boolean] + [Primitive byte //descriptor.byte] + [Primitive short //descriptor.short] + [Primitive int //descriptor.int] + [Primitive long //descriptor.long] + [Primitive float //descriptor.float] + [Primitive double //descriptor.double] + [Primitive char //descriptor.char] + ) + + (def: #export array + (-> (Signature Value) (Signature Array)) + (|>> :representation + (format //descriptor.array_prefix) + :abstraction)) + + (def: #export wildcard + (Signature Parameter) + (:abstraction "*")) + + (def: #export var_prefix "T") + + (def: #export var + (-> Text (Signature Var)) + (|>> (text.enclose [..var_prefix //descriptor.class_suffix]) + :abstraction)) + + (def: #export lower_prefix "-") + (def: #export upper_prefix "+") + + (template [<name> <prefix>] + [(def: #export <name> + (-> (Signature Class) (Signature Parameter)) + (|>> :representation (format <prefix>) :abstraction))] + + [lower ..lower_prefix] + [upper ..upper_prefix] + ) + + (def: #export parameters_start "<") + (def: #export parameters_end ">") + + (def: #export (class name parameters) + (-> External (List (Signature Parameter)) (Signature Class)) + (:abstraction + (format //descriptor.class_prefix + (|> name ///name.internal ///name.read) + (case parameters + #.Nil + "" + + _ + (format ..parameters_start + (|> parameters + (list\map ..signature) + (text.join_with "")) + ..parameters_end)) + //descriptor.class_suffix))) + + (def: #export (declaration name variables) + (-> External (List (Signature Var)) (Signature Declaration)) + (:transmutation (..class name variables))) + + (def: #export as_class + (-> (Signature Declaration) (Signature Class)) + (|>> :transmutation)) + + (def: #export arguments_start "(") + (def: #export arguments_end ")") + + (def: #export exception_prefix "^") + + (def: #export (method [inputs output exceptions]) + (-> [(List (Signature Value)) + (Signature Return) + (List (Signature Class))] + (Signature Method)) + (:abstraction + (format (|> inputs + (list\map ..signature) + (text.join_with "") + (text.enclose [..arguments_start + ..arguments_end])) + (:representation output) + (|> exceptions + (list\map (|>> :representation (format ..exception_prefix))) + (text.join_with ""))))) + + (implementation: #export equivalence + (All [category] (Equivalence (Signature category))) + + (def: (= parameter subject) + (text\= (:representation parameter) + (:representation subject)))) + + (implementation: #export hash + (All [category] (Hash (Signature category))) + + (def: &equivalence ..equivalence) + (def: hash (|>> :representation text\hash))) + ) diff --git a/stdlib/source/library/lux/target/jvm/version.lux b/stdlib/source/library/lux/target/jvm/version.lux new file mode 100644 index 000000000..0aaf297de --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/version.lux @@ -0,0 +1,38 @@ +(.module: + [library + [lux #* + [control + ["." try]]]] + ["." // #_ + [encoding + ["#." unsigned (#+ U2)]]]) + +(type: #export Version U2) +(type: #export Minor Version) +(type: #export Major Version) + +(def: #export default_minor + Minor + (|> 0 //unsigned.u2 try.assume)) + +(template [<number> <name>] + [(def: #export <name> + Major + (|> <number> //unsigned.u2 try.assume))] + + [45 v1_1] + [46 v1_2] + [47 v1_3] + [48 v1_4] + [49 v5_0] + [50 v6_0] + [51 v7] + [52 v8] + [53 v9] + [54 v10] + [55 v11] + [56 v12] + ) + +(def: #export writer + //unsigned.writer/2) diff --git a/stdlib/source/library/lux/target/lua.lux b/stdlib/source/library/lux/target/lua.lux new file mode 100644 index 000000000..7e0202481 --- /dev/null +++ b/stdlib/source/library/lux/target/lua.lux @@ -0,0 +1,416 @@ +(.module: + [library + [lux (#- Location Code int if cond function or and not let ^) + ["@" target] + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + ["." enum]] + [control + [pipe (#+ case> cond> new>)] + [parser + ["<.>" code]]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [macro + [syntax (#+ syntax:)] + ["." template] + ["." code]] + [math + [number + ["n" nat] + ["i" int] + ["f" frac]]] + [type + abstract]]]) + +(def: nest + (-> Text Text) + (.let [nested_new_line (format text.new_line text.tab)] + (|>> (format text.new_line) + (text.replace_all text.new_line nested_new_line)))) + +(def: input_separator ", ") + +(abstract: #export (Code brand) + Text + + (implementation: #export equivalence + (All [brand] (Equivalence (Code brand))) + + (def: (= reference subject) + (\ text.equivalence = (:representation reference) (:representation subject)))) + + (implementation: #export hash + (All [brand] (Hash (Code brand))) + + (def: &equivalence ..equivalence) + (def: hash (|>> :representation (\ text.hash hash)))) + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (template [<type> <super>+] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (abstract: (<brand> brand) Any) + (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))] + + [Expression [Code]] + [Computation [Expression' Code]] + [Location [Computation' Expression' Code]] + [Statement [Code]] + ) + + (template [<type> <super>+] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (abstract: #export <brand> Any) + (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))] + + [Literal [Computation' Expression' Code]] + [Var [Location' Computation' Expression' Code]] + [Access [Location' Computation' Expression' Code]] + [Label [Code]] + ) + + (def: #export nil + Literal + (:abstraction "nil")) + + (def: #export bool + (-> Bit Literal) + (|>> (case> #0 "false" + #1 "true") + :abstraction)) + + (def: #export int + (-> Int Literal) + ## Integers must be turned into hexadecimal to avoid quirks in how Lua parses integers. + ## In particular, the number -9223372036854775808 will be incorrectly parsed as a float by Lua. + (.let [to_hex (\ n.hex encode)] + (|>> .nat + to_hex + (format "0x") + :abstraction))) + + (def: #export float + (-> Frac Literal) + (|>> (cond> [(f.= f.positive_infinity)] + [(new> "(1.0/0.0)" [])] + + [(f.= f.negative_infinity)] + [(new> "(-1.0/0.0)" [])] + + [(f.= f.not_a_number)] + [(new> "(0.0/0.0)" [])] + + ## else + [%.frac (text.replace_all "+" "")]) + :abstraction)) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [<find> <replace>] + [(text.replace_all <find> <replace>)] + + ["\" "\\"] + [text.tab "\t"] + [text.vertical_tab "\v"] + [text.null "\0"] + [text.back_space "\b"] + [text.form_feed "\f"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] + )) + ))) + + (def: #export string + (-> Text Literal) + (|>> ..sanitize (text.enclose' text.double_quote) :abstraction)) + + (def: #export multi + (-> (List Expression) Literal) + (|>> (list\map ..code) + (text.join_with ..input_separator) + :abstraction)) + + (def: #export array + (-> (List Expression) Literal) + (|>> (list\map ..code) + (text.join_with ..input_separator) + (text.enclose ["{" "}"]) + :abstraction)) + + (def: #export table + (-> (List [Text Expression]) Literal) + (|>> (list\map (.function (_ [key value]) + (format key " = " (:representation value)))) + (text.join_with ..input_separator) + (text.enclose ["{" "}"]) + :abstraction)) + + (def: #export (nth idx array) + (-> Expression Expression Access) + (:abstraction (format (:representation array) "[" (:representation idx) "]"))) + + (def: #export (the field table) + (-> Text Expression Computation) + (:abstraction (format (:representation table) "." field))) + + (def: #export length + (-> Expression Computation) + (|>> :representation + (text.enclose ["#(" ")"]) + :abstraction)) + + (def: #export (apply/* args func) + (-> (List Expression) Expression Computation) + (|> args + (list\map ..code) + (text.join_with ..input_separator) + (text.enclose ["(" ")"]) + (format (:representation func)) + :abstraction)) + + (def: #export (do method args table) + (-> Text (List Expression) Expression Computation) + (|> args + (list\map ..code) + (text.join_with ..input_separator) + (text.enclose ["(" ")"]) + (format (:representation table) ":" method) + :abstraction)) + + (template [<op> <name>] + [(def: #export (<name> parameter subject) + (-> Expression Expression Expression) + (:abstraction (format "(" + (:representation subject) + " " <op> " " + (:representation parameter) + ")")))] + + ["==" =] + ["<" <] + ["<=" <=] + [">" >] + [">=" >=] + ["+" +] + ["-" -] + ["*" *] + ["^" ^] + ["/" /] + ["//" //] + ["%" %] + [".." concat] + + ["or" or] + ["and" and] + ["|" bit_or] + ["&" bit_and] + ["~" bit_xor] + + ["<<" bit_shl] + [">>" bit_shr] + ) + + (template [<name> <unary>] + [(def: #export (<name> subject) + (-> Expression Expression) + (:abstraction (format "(" <unary> " " (:representation subject) ")")))] + + [not "not"] + [negate "-"] + ) + + (template [<name> <type>] + [(def: #export <name> + (-> Text <type>) + (|>> :abstraction))] + + [var Var] + [label Label] + ) + + (def: #export statement + (-> Expression Statement) + (|>> :representation :abstraction)) + + (def: #export (then pre! post!) + (-> Statement Statement Statement) + (:abstraction + (format (:representation pre!) + text.new_line + (:representation post!)))) + + (def: locations + (-> (List Location) Text) + (|>> (list\map ..code) + (text.join_with ..input_separator))) + + (def: #export (local vars) + (-> (List Var) Statement) + (:abstraction (format "local " (..locations vars)))) + + (def: #export (set vars value) + (-> (List Location) Expression Statement) + (:abstraction (format (..locations vars) " = " (:representation value)))) + + (def: #export (let vars value) + (-> (List Var) Expression Statement) + (:abstraction (format "local " (..locations vars) " = " (:representation value)))) + + (def: #export (local/1 var value) + (-> Var Expression Statement) + (:abstraction (format "local " (:representation var) " = " (:representation value)))) + + (def: #export (if test then! else!) + (-> Expression Statement Statement Statement) + (:abstraction (format "if " (:representation test) + text.new_line "then" (..nest (:representation then!)) + text.new_line "else" (..nest (:representation else!)) + text.new_line "end"))) + + (def: #export (when test then!) + (-> Expression Statement Statement) + (:abstraction (format "if " (:representation test) + text.new_line "then" (..nest (:representation then!)) + text.new_line "end"))) + + (def: #export (while test body!) + (-> Expression Statement Statement) + (:abstraction + (format "while " (:representation test) " do" + (..nest (:representation body!)) + text.new_line "end"))) + + (def: #export (repeat until body!) + (-> Expression Statement Statement) + (:abstraction + (format "repeat" + (..nest (:representation body!)) + text.new_line "until " (:representation until)))) + + (def: #export (for_in vars source body!) + (-> (List Var) Expression Statement Statement) + (:abstraction + (format "for " (|> vars + (list\map ..code) + (text.join_with ..input_separator)) + " in " (:representation source) " do" + (..nest (:representation body!)) + text.new_line "end"))) + + (def: #export (for_step var from to step body!) + (-> Var Expression Expression Expression Statement + Statement) + (:abstraction + (format "for " (:representation var) + " = " (:representation from) + ..input_separator (:representation to) + ..input_separator (:representation step) " do" + (..nest (:representation body!)) + text.new_line "end"))) + + (def: #export (return value) + (-> Expression Statement) + (:abstraction (format "return " (:representation value)))) + + (def: #export (closure args body!) + (-> (List Var) Statement Expression) + (|> (format "function " (|> args + ..locations + (text.enclose ["(" ")"])) + (..nest (:representation body!)) + text.new_line "end") + (text.enclose ["(" ")"]) + :abstraction)) + + (template [<name> <code>] + [(def: #export (<name> name args body!) + (-> Var (List Var) Statement Statement) + (:abstraction + (format <code> " " (:representation name) + (|> args + ..locations + (text.enclose ["(" ")"])) + (..nest (:representation body!)) + text.new_line "end")))] + + [function "function"] + [local_function "local function"] + ) + + (def: #export break + Statement + (:abstraction "break")) + + (def: #export (set_label label) + (-> Label Statement) + (:abstraction (format "::" (:representation label) "::"))) + + (def: #export (go_to label) + (-> Label Statement) + (:abstraction (format "goto " (:representation label)))) + ) + +(def: #export (cond clauses else!) + (-> (List [Expression Statement]) Statement Statement) + (list\fold (.function (_ [test then!] next!) + (..if test then! next!)) + else! + (list.reverse clauses))) + +(syntax: (arity_inputs {arity <code>.nat}) + (wrap (case arity + 0 (.list) + _ (|> (dec arity) + (enum.range n.enum 0) + (list\map (|>> %.nat code.local_identifier)))))) + +(syntax: (arity_types {arity <code>.nat}) + (wrap (list.repeat arity (` ..Expression)))) + +(template [<arity> <function>+] + [(with_expansions [<apply> (template.identifier ["apply/" <arity>]) + <inputs> (arity_inputs <arity>) + <types> (arity_types <arity>) + <definitions> (template.splice <function>+)] + (def: #export (<apply> function <inputs>) + (-> Expression <types> Computation) + (..apply/* (.list <inputs>) function)) + + (template [<function>] + [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>])) + (<apply> (..var <function>))))] + + <definitions>))] + + [1 + [["error"] + ["print"] + ["require"] + ["type"] + ["ipairs"]]] + + [2 + [["print"] + ["error"]]] + + [3 + [["print"]]] + + [4 + []] + + [5 + []] + ) diff --git a/stdlib/source/library/lux/target/php.lux b/stdlib/source/library/lux/target/php.lux new file mode 100644 index 000000000..6a3e01fbb --- /dev/null +++ b/stdlib/source/library/lux/target/php.lux @@ -0,0 +1,545 @@ +(.module: + [library + [lux (#- Location Code Global static int if cond or and not comment for try) + ["@" target] + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + ["." enum]] + [control + [pipe (#+ case> cond> new>)] + [parser + ["<.>" code]]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [macro + [syntax (#+ syntax:)] + ["." template] + ["." code]] + [math + [number + ["n" nat] + ["f" frac]]] + [type + abstract]]]) + +(def: input_separator ", ") +(def: statement_suffix ";") + +(def: nest + (-> Text Text) + (.let [nested_new_line (format text.new_line text.tab)] + (|>> (format text.new_line) + (text.replace_all text.new_line nested_new_line)))) + +(def: block + (-> Text Text) + (|>> ..nest (text.enclose ["{" (format text.new_line "}")]))) + +(def: group + (-> Text Text) + (text.enclose ["(" ")"])) + +(abstract: #export (Code brand) + Text + + (implementation: #export equivalence + (All [brand] (Equivalence (Code brand))) + + (def: (= reference subject) + (\ text.equivalence = (:representation reference) (:representation subject)))) + + (implementation: #export hash + (All [brand] (Hash (Code brand))) + + (def: &equivalence ..equivalence) + (def: hash (|>> :representation (\ text.hash hash)))) + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (template [<type> <super>+] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (abstract: (<brand> brand) Any) + (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))] + + [Expression [Code]] + [Computation [Expression' Code]] + [Location [Computation' Expression' Code]] + [Statement [Code]] + ) + + (template [<type> <super>+] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (abstract: #export <brand> Any) + (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))] + + [Literal [Computation' Expression' Code]] + [Var [Location' Computation' Expression' Code]] + [Access [Location' Computation' Expression' Code]] + [Constant [Location' Computation' Expression' Code]] + [Global [Location' Computation' Expression' Code]] + [Label [Code]] + ) + + (type: #export Argument + {#reference? Bit + #var Var}) + + (def: #export ; + (-> Expression Statement) + (|>> :representation + (text.suffix ..statement_suffix) + :abstraction)) + + (def: #export var + (-> Text Var) + (|>> (format "$") :abstraction)) + + (template [<name> <type>] + [(def: #export <name> + (-> Text <type>) + (|>> :abstraction))] + + [constant Constant] + [label Label] + ) + + (def: #export (set_label label) + (-> Label Statement) + (:abstraction (format (:representation label) ":"))) + + (def: #export (go_to label) + (-> Label Statement) + (:abstraction + (format "goto " (:representation label) ..statement_suffix))) + + (def: #export null + Literal + (:abstraction "NULL")) + + (def: #export bool + (-> Bit Literal) + (|>> (case> #0 "false" + #1 "true") + :abstraction)) + + (def: #export int + (-> Int Literal) + (.let [to_hex (\ n.hex encode)] + (|>> .nat + to_hex + (format "0x") + :abstraction))) + + (def: #export float + (-> Frac Literal) + (|>> (cond> [(f.= f.positive_infinity)] + [(new> "+INF" [])] + + [(f.= f.negative_infinity)] + [(new> "-INF" [])] + + [(f.= f.not_a_number)] + [(new> "NAN" [])] + + ## else + [%.frac]) + :abstraction)) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [<find> <replace>] + [(text.replace_all <find> <replace>)] + + ["\" "\\"] + [text.tab "\t"] + [text.vertical_tab "\v"] + [text.null "\0"] + [text.back_space "\b"] + [text.form_feed "\f"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] + ["$" "\$"] + )) + ))) + + (def: #export string + (-> Text Literal) + (|>> ..sanitize + (text.enclose [text.double_quote text.double_quote]) + :abstraction)) + + (def: arguments + (-> (List Expression) Text) + (|>> (list\map ..code) (text.join_with ..input_separator) ..group)) + + (def: #export (apply/* args func) + (-> (List Expression) Expression Computation) + (|> (format (:representation func) (..arguments args)) + :abstraction)) + + ## TODO: Remove when no longer using JPHP. + (def: #export (apply/*' args func) + (-> (List Expression) Expression Computation) + (apply/* (list& func args) (..constant "call_user_func"))) + + (def: parameters + (-> (List Argument) Text) + (|>> (list\map (function (_ [reference? var]) + (.if reference? + (format "&" (:representation var)) + (:representation var)))) + (text.join_with ..input_separator) + ..group)) + + (template [<name> <reference?>] + [(def: #export <name> + (-> Var Argument) + (|>> [<reference?>]))] + + [parameter #0] + [reference #1] + ) + + (def: #export (closure uses arguments body!) + (-> (List Argument) (List Argument) Statement Literal) + (let [uses (case uses + #.Nil + "" + + _ + (format "use " (..parameters uses)))] + (|> (format "function " (..parameters arguments) + " " uses " " + (..block (:representation body!))) + ..group + :abstraction))) + + (syntax: (arity_inputs {arity <code>.nat}) + (wrap (case arity + 0 (.list) + _ (|> (dec arity) + (enum.range n.enum 0) + (list\map (|>> %.nat code.local_identifier)))))) + + (syntax: (arity_types {arity <code>.nat}) + (wrap (list.repeat arity (` ..Expression)))) + + (template [<arity> <function>+] + [(with_expansions [<apply> (template.identifier ["apply/" <arity>]) + <inputs> (arity_inputs <arity>) + <types> (arity_types <arity>) + <definitions> (template.splice <function>+)] + (def: #export (<apply> function [<inputs>]) + (-> Expression [<types>] Computation) + (..apply/* (.list <inputs>) function)) + + (template [<function>] + [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>])) + (<apply> (..constant <function>))))] + + <definitions>))] + + [0 + [["func_num_args"] + ["func_get_args"] + ["time"] + ["phpversion"]]] + + [1 + [["isset"] + ["var_dump"] + ["is_null"] + ["empty"] + ["count"] + ["array_pop"] + ["array_reverse"] + ["intval"] + ["floatval"] + ["strval"] + ["ord"] + ["chr"] + ["print"] + ["exit"] + ["iconv_strlen"] ["strlen"] + ["log"] + ["ceil"] + ["floor"] + ["is_nan"]]] + + [2 + [["intdiv"] + ["fmod"] + ["number_format"] + ["array_key_exists"] + ["call_user_func_array"] + ["array_slice"] + ["array_push"] + ["pack"] + ["unpack"] + ["iconv_strpos"] ["strpos"] + ["pow"] + ["max"]]] + + [3 + [["array_fill"] + ["array_slice"] + ["array_splice"] + ["iconv"] + ["iconv_strpos"] ["strpos"] + ["iconv_substr"] ["substr"]]] + ) + + (def: #export (key_value key value) + (-> Expression Expression Expression) + (:abstraction (format (:representation key) " => " (:representation value)))) + + (def: #export (array/* values) + (-> (List Expression) Literal) + (|> values + (list\map ..code) + (text.join_with ..input_separator) + ..group + (format "array") + :abstraction)) + + (def: #export (array_merge/+ required optionals) + (-> Expression (List Expression) Computation) + (..apply/* (list& required optionals) (..constant "array_merge"))) + + (def: #export (array/** kvs) + (-> (List [Expression Expression]) Literal) + (|> kvs + (list\map (function (_ [key value]) + (format (:representation key) " => " (:representation value)))) + (text.join_with ..input_separator) + ..group + (format "array") + :abstraction)) + + (def: #export (new constructor inputs) + (-> Constant (List Expression) Computation) + (|> (format "new " (:representation constructor) (arguments inputs)) + :abstraction)) + + (def: #export (the field object) + (-> Text Expression Computation) + (|> (format (:representation object) "->" field) + :abstraction)) + + (def: #export (do method inputs object) + (-> Text (List Expression) Expression Computation) + (|> (format (:representation (..the method object)) + (..arguments inputs)) + :abstraction)) + + (def: #export (nth idx array) + (-> Expression Expression Access) + (|> (format (:representation array) "[" (:representation idx) "]") + :abstraction)) + + (def: #export (global name) + (-> Text Global) + (|> (..var "GLOBALS") (..nth (..string name)) :transmutation)) + + (def: #export (? test then else) + (-> Expression Expression Expression Computation) + (|> (format (..group (:representation test)) " ? " + (..group (:representation then)) " : " + (..group (:representation else))) + ..group + :abstraction)) + + (template [<name> <op>] + [(def: #export (<name> parameter subject) + (-> Expression Expression Computation) + (|> (format (:representation subject) " " <op> " " (:representation parameter)) + ..group + :abstraction))] + + [or "||"] + [and "&&"] + [== "=="] + [=== "==="] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + [+ "+"] + [- "-"] + [* "*"] + [/ "/"] + [% "%"] + [bit_or "|"] + [bit_and "&"] + [bit_xor "^"] + [bit_shl "<<"] + [bit_shr ">>"] + [concat "."] + ) + + (template [<unary> <name>] + [(def: #export <name> + (-> Computation Computation) + (|>> :representation (format <unary>) :abstraction))] + + ["!" not] + ["~" bit_not] + ["-" negate] + ) + + (def: #export (set var value) + (-> Location Expression Computation) + (|> (format (:representation var) " = " (:representation value)) + ..group + :abstraction)) + + (def: #export (set! var value) + (-> Location Expression Statement) + (:abstraction (format (:representation var) " = " (:representation value) ";"))) + + (def: #export (set? var) + (-> Var Computation) + (..apply/1 [var] (..constant "isset"))) + + (template [<name> <modifier>] + [(def: #export <name> + (-> Var Statement) + (|>> :representation (format <modifier> " ") (text.suffix ..statement_suffix) :abstraction))] + + [define_global "global"] + ) + + (template [<name> <modifier> <location>] + [(def: #export (<name> location value) + (-> <location> Expression Statement) + (:abstraction (format <modifier> " " (:representation location) + " = " (:representation value) + ..statement_suffix)))] + + [define_static "static" Var] + [define_constant "const" Constant] + ) + + (def: #export (if test then! else!) + (-> Expression Statement Statement Statement) + (:abstraction + (format "if" (..group (:representation test)) " " + (..block (:representation then!)) + " else " + (..block (:representation else!))))) + + (def: #export (when test then!) + (-> Expression Statement Statement) + (:abstraction + (format "if" (..group (:representation test)) " " + (..block (:representation then!))))) + + (def: #export (then pre! post!) + (-> Statement Statement Statement) + (:abstraction + (format (:representation pre!) + text.new_line + (:representation post!)))) + + (def: #export (while test body!) + (-> Expression Statement Statement) + (:abstraction + (format "while" (..group (:representation test)) " " + (..block (:representation body!))))) + + (def: #export (do_while test body!) + (-> Expression Statement Statement) + (:abstraction + (format "do " (..block (:representation body!)) + " while" (..group (:representation test)) + ..statement_suffix))) + + (def: #export (for_each array value body!) + (-> Expression Var Statement Statement) + (:abstraction + (format "foreach(" (:representation array) + " as " (:representation value) + ") " (..block (:representation body!))))) + + (type: #export Except + {#class Constant + #exception Var + #handler Statement}) + + (def: (catch except) + (-> Except Text) + (let [declaration (format (:representation (get@ #class except)) + " " (:representation (get@ #exception except)))] + (format "catch" (..group declaration) " " + (..block (:representation (get@ #handler except)))))) + + (def: #export (try body! excepts) + (-> Statement (List Except) Statement) + (:abstraction + (format "try " (..block (:representation body!)) + text.new_line + (|> excepts + (list\map catch) + (text.join_with text.new_line))))) + + (template [<name> <keyword>] + [(def: #export <name> + (-> Expression Statement) + (|>> :representation (format <keyword> " ") (text.suffix ..statement_suffix) :abstraction))] + + [throw "throw"] + [return "return"] + [echo "echo"] + ) + + (def: #export (define name value) + (-> Constant Expression Expression) + (..apply/2 (..constant "define") + [(|> name :representation ..string) + value])) + + (def: #export (define_function name arguments body!) + (-> Constant (List Argument) Statement Statement) + (:abstraction + (format "function " (:representation name) + (..parameters arguments) + " " + (..block (:representation body!))))) + + (template [<name> <keyword>] + [(def: #export <name> + Statement + (|> <keyword> + (text.suffix ..statement_suffix) + :abstraction))] + + [break "break"] + [continue "continue"] + ) + + (def: #export splat + (-> Expression Expression) + (|>> :representation (format "...") :abstraction)) + ) + +(def: #export (cond clauses else!) + (-> (List [Expression Statement]) Statement Statement) + (list\fold (function (_ [test then!] next!) + (..if test then! next!)) + else! + (list.reverse clauses))) + +(def: #export command_line_arguments + Var + (..var "argv")) diff --git a/stdlib/source/library/lux/target/python.lux b/stdlib/source/library/lux/target/python.lux new file mode 100644 index 000000000..49c3d8612 --- /dev/null +++ b/stdlib/source/library/lux/target/python.lux @@ -0,0 +1,501 @@ +(.module: + [library + [lux (#- Location Code not or and list if cond int comment exec try) + ["@" target] + ["." ffi] + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + ["." enum]] + [control + [pipe (#+ new> case> cond>)] + [parser + ["<.>" code]]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [macro + [syntax (#+ syntax:)] + ["." template] + ["." code]] + [math + [number + ["n" nat] + ["f" frac]]] + [type + abstract]]]) + +(def: expression + (-> Text Text) + (text.enclose ["(" ")"])) + +(for {@.old (as_is (ffi.import: java/lang/CharSequence) + (ffi.import: java/lang/String + ["#::." + (replace [java/lang/CharSequence java/lang/CharSequence] java/lang/String)]))} + (as_is)) + +(def: nest + (-> Text Text) + (.let [nested_new_line (format text.new_line text.tab)] + (for {@.old (|>> (format text.new_line) + (:as java/lang/String) + (java/lang/String::replace (:as java/lang/CharSequence text.new_line) + (:as java/lang/CharSequence nested_new_line)))} + (|>> (format text.new_line) + (text.replace_all text.new_line nested_new_line))))) + +(abstract: #export (Code brand) + Text + + (implementation: #export equivalence + (All [brand] (Equivalence (Code brand))) + + (def: (= reference subject) + (\ text.equivalence = (:representation reference) (:representation subject)))) + + (implementation: #export hash + (All [brand] (Hash (Code brand))) + + (def: &equivalence ..equivalence) + (def: hash (|>> :representation (\ text.hash hash)))) + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (template [<type> <super>] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (`` (abstract: #export (<brand> brand) Any)) + (`` (type: #export (<type> brand) + (<super> (<brand> brand)))))] + + [Expression Code] + [Computation Expression] + [Location Computation] + [Var Location] + [Statement Code] + ) + + (template [<type> <super>] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (`` (abstract: #export <brand> Any)) + (`` (type: #export <type> (<super> <brand>))))] + + [Literal Computation] + [Access Location] + [Loop Statement] + [Label Code] + ) + + (template [<var> <brand>] + [(abstract: #export <brand> Any) + + (type: #export <var> (Var <brand>))] + + [SVar Single] + [PVar Poly] + [KVar Keyword] + ) + + (def: #export var + (-> Text SVar) + (|>> :abstraction)) + + (template [<name> <brand> <prefix>] + [(def: #export <name> + (-> SVar (Var <brand>)) + (|>> :representation (format <prefix>) :abstraction))] + + [poly Poly "*"] + [keyword Keyword "**"] + ) + + (def: #export none + Literal + (:abstraction "None")) + + (def: #export bool + (-> Bit Literal) + (|>> (case> #0 "False" + #1 "True") + :abstraction)) + + (def: #export int + (-> Int Literal) + (|>> %.int :abstraction)) + + (def: #export (long value) + (-> Int Literal) + (:abstraction (format (%.int value) "L"))) + + (def: #export float + (-> Frac Literal) + (`` (|>> (cond> (~~ (template [<test> <python>] + [[<test>] + [(new> (format "float(" text.double_quote <python> text.double_quote ")") [])]] + + [(f.= f.positive_infinity) "inf"] + [(f.= f.negative_infinity) "-inf"] + [f.not_a_number? "nan"] + )) + + ## else + [%.frac]) + :abstraction))) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [<find> <replace>] + [(text.replace_all <find> <replace>)] + + ["\" "\\"] + [text.tab "\t"] + [text.vertical_tab "\v"] + [text.null "\0"] + [text.back_space "\b"] + [text.form_feed "\f"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] + )) + ))) + + (def: #export string + (-> Text Literal) + (|>> ..sanitize + (text.enclose [text.double_quote text.double_quote]) + :abstraction)) + + (def: #export unicode + (-> Text Literal) + (|>> ..string + :representation + (format "u") + :abstraction)) + + (def: (composite_literal left_delimiter right_delimiter entry_serializer) + (All [a] + (-> Text Text (-> a Text) + (-> (List a) Literal))) + (function (_ entries) + (<| :abstraction + ## ..expression + (format left_delimiter + (|> entries + (list\map entry_serializer) + (text.join_with ", ")) + right_delimiter)))) + + (template [<name> <pre> <post>] + [(def: #export <name> + (-> (List (Expression Any)) Literal) + (composite_literal <pre> <post> ..code))] + + [tuple "(" ")"] + [list "[" "]"] + ) + + (def: #export (slice from to list) + (-> (Expression Any) (Expression Any) (Expression Any) Access) + (<| :abstraction + ## ..expression + (format (:representation list) "[" (:representation from) ":" (:representation to) "]"))) + + (def: #export (slice_from from list) + (-> (Expression Any) (Expression Any) Access) + (<| :abstraction + ## ..expression + (format (:representation list) "[" (:representation from) ":]"))) + + (def: #export dict + (-> (List [(Expression Any) (Expression Any)]) (Computation Any)) + (composite_literal "{" "}" (.function (_ [k v]) (format (:representation k) " : " (:representation v))))) + + (def: #export (apply/* func args) + (-> (Expression Any) (List (Expression Any)) (Computation Any)) + (<| :abstraction + ## ..expression + (format (:representation func) "(" (text.join_with ", " (list\map ..code args)) ")"))) + + (template [<name> <brand> <prefix>] + [(def: (<name> var) + (-> (Expression Any) Text) + (format <prefix> (:representation var)))] + + [splat_poly Poly "*"] + [splat_keyword Keyword "**"] + ) + + (template [<name> <splat>] + [(def: #export (<name> args extra func) + (-> (List (Expression Any)) (Expression Any) (Expression Any) (Computation Any)) + (<| :abstraction + ## ..expression + (format (:representation func) + (format "(" (|> args + (list\map (function (_ arg) (format (:representation arg) ", "))) + (text.join_with "")) + (<splat> extra) ")"))))] + + [apply_poly splat_poly] + [apply_keyword splat_keyword] + ) + + (def: #export (the name object) + (-> Text (Expression Any) (Computation Any)) + (:abstraction (format (:representation object) "." name))) + + (def: #export (do method args object) + (-> Text (List (Expression Any)) (Expression Any) (Computation Any)) + (..apply/* (..the method object) args)) + + (template [<name> <apply>] + [(def: #export (<name> args extra method) + (-> (List (Expression Any)) (Expression Any) Text + (-> (Expression Any) (Computation Any))) + (|>> (..the method) (<apply> args extra)))] + + [do_poly apply_poly] + [do_keyword apply_keyword] + ) + + (def: #export (nth idx array) + (-> (Expression Any) (Expression Any) Location) + (:abstraction (format (:representation array) "[" (:representation idx) "]"))) + + (def: #export (? test then else) + (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) + (<| :abstraction + ..expression + (format (:representation then) " if " (:representation test) " else " (:representation else)))) + + (template [<name> <op>] + [(def: #export (<name> param subject) + (-> (Expression Any) (Expression Any) (Computation Any)) + (<| :abstraction + ..expression + (format (:representation subject) " " <op> " " (:representation param))))] + + [is "is"] + [= "=="] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + [+ "+"] + [- "-"] + [* "*"] + [/ "/"] + [// "//"] + [% "%"] + [** "**"] + [bit_or "|"] + [bit_and "&"] + [bit_xor "^"] + [bit_shl "<<"] + [bit_shr ">>"] + + [or "or"] + [and "and"] + ) + + (template [<name> <unary>] + [(def: #export (<name> subject) + (-> (Expression Any) (Computation Any)) + (<| :abstraction + ## ..expression + (format <unary> " " (:representation subject))))] + + [not "not"] + [negate "-"] + ) + + (def: #export (lambda arguments body) + (-> (List (Var Any)) (Expression Any) (Computation Any)) + (<| :abstraction + ..expression + (format "lambda " (|> arguments (list\map ..code) (text.join_with ", ")) ": " + (:representation body)))) + + (def: #export (set vars value) + (-> (List (Location Any)) (Expression Any) (Statement Any)) + (:abstraction + (format (|> vars (list\map ..code) (text.join_with ", ")) + " = " + (:representation value)))) + + (def: #export (delete where) + (-> (Location Any) (Statement Any)) + (:abstraction (format "del " (:representation where)))) + + (def: #export (if test then! else!) + (-> (Expression Any) (Statement Any) (Statement Any) (Statement Any)) + (:abstraction + (format "if " (:representation test) ":" + (..nest (:representation then!)) + text.new_line "else:" + (..nest (:representation else!))))) + + (def: #export (when test then!) + (-> (Expression Any) (Statement Any) (Statement Any)) + (:abstraction + (format "if " (:representation test) ":" + (..nest (:representation then!))))) + + (def: #export (then pre! post!) + (-> (Statement Any) (Statement Any) (Statement Any)) + (:abstraction + (format (:representation pre!) + text.new_line + (:representation post!)))) + + (template [<keyword> <0>] + [(def: #export <0> + (Statement Any) + (:abstraction <keyword>))] + + ["break" break] + ["continue" continue] + ) + + (def: #export (while test body! else!) + (-> (Expression Any) (Statement Any) (Maybe (Statement Any)) Loop) + (:abstraction + (format "while " (:representation test) ":" + (..nest (:representation body!)) + (case else! + (#.Some else!) + (format text.new_line "else:" + (..nest (:representation else!))) + + #.None + "")))) + + (def: #export (for_in var inputs body!) + (-> SVar (Expression Any) (Statement Any) Loop) + (:abstraction + (format "for " (:representation var) " in " (:representation inputs) ":" + (..nest (:representation body!))))) + + (def: #export statement + (-> (Expression Any) (Statement Any)) + (|>> :transmutation)) + + (def: #export pass + (Statement Any) + (:abstraction "pass")) + + (type: #export Except + {#classes (List SVar) + #exception SVar + #handler (Statement Any)}) + + (def: #export (try body! excepts) + (-> (Statement Any) (List Except) (Statement Any)) + (:abstraction + (format "try:" + (..nest (:representation body!)) + (|> excepts + (list\map (function (_ [classes exception catch!]) + (format text.new_line "except (" (text.join_with ", " (list\map ..code classes)) + ") as " (:representation exception) ":" + (..nest (:representation catch!))))) + (text.join_with ""))))) + + (template [<name> <keyword> <pre>] + [(def: #export (<name> value) + (-> (Expression Any) (Statement Any)) + (:abstraction + (format <keyword> (<pre> (:representation value)))))] + + [raise "raise " |>] + [return "return " |>] + [print "print" ..expression] + ) + + (def: #export (exec code globals) + (-> (Expression Any) (Maybe (Expression Any)) (Statement Any)) + (let [extra (case globals + (#.Some globals) + (.list globals) + + #.None + (.list))] + (:abstraction + (format "exec" (:representation (..tuple (list& code extra))))))) + + (def: #export (def name args body) + (-> SVar (List (Ex [k] (Var k))) (Statement Any) (Statement Any)) + (:abstraction + (format "def " (:representation name) + "(" (|> args (list\map ..code) (text.join_with ", ")) "):" + (..nest (:representation body))))) + + (def: #export (import module_name) + (-> Text (Statement Any)) + (:abstraction (format "import " module_name))) + + (def: #export (comment commentary on) + (All [brand] (-> Text (Code brand) (Code brand))) + (:abstraction (format "# " (..sanitize commentary) text.new_line + (:representation on)))) + ) + +(def: #export (cond clauses else!) + (-> (List [(Expression Any) (Statement Any)]) (Statement Any) (Statement Any)) + (list\fold (.function (_ [test then!] next!) + (..if test then! next!)) + else! + (list.reverse clauses))) + +(syntax: (arity_inputs {arity <code>.nat}) + (wrap (case arity + 0 (.list) + _ (|> (dec arity) + (enum.range n.enum 0) + (list\map (|>> %.nat code.local_identifier)))))) + +(syntax: (arity_types {arity <code>.nat}) + (wrap (list.repeat arity (` (Expression Any))))) + +(template [<arity> <function>+] + [(with_expansions [<apply> (template.identifier ["apply/" <arity>]) + <inputs> (arity_inputs <arity>) + <types> (arity_types <arity>) + <definitions> (template.splice <function>+)] + (def: #export (<apply> function <inputs>) + (-> (Expression Any) <types> (Computation Any)) + (..apply/* function (.list <inputs>))) + + (template [<function>] + [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>])) + (<apply> (..var <function>))))] + + <definitions>))] + + [1 + [["str"] + ["ord"] + ["float"] + ["int"] + ["len"] + ["chr"] + ["unichr"] + ["unicode"] + ["repr"] + ["__import__"] + ["Exception"]]] + + [2 + []] + + [3 + []] + ) diff --git a/stdlib/source/library/lux/target/r.lux b/stdlib/source/library/lux/target/r.lux new file mode 100644 index 000000000..fee2e206b --- /dev/null +++ b/stdlib/source/library/lux/target/r.lux @@ -0,0 +1,386 @@ +(.module: + [library + [lux (#- Code or and list if function cond not int) + [control + [pipe (#+ case> cond> new>)] + ["." function] + [parser + ["<.>" code]]] + [data + ["." maybe ("#\." functor)] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [macro + [syntax (#+ syntax:)] + ["." template] + ["." code]] + [math + [number + ["f" frac]]] + [type + abstract]]]) + +(abstract: #export (Code kind) + Text + + {} + + (template [<type> <super>+] + [(with_expansions [<kind> (template.identifier [<type> "'"])] + (abstract: #export (<kind> kind) Any) + (`` (type: #export <type> (|> Any <kind> (~~ (template.splice <super>+))))))] + + [Expression [Code]] + ) + + (template [<type> <super>+] + [(with_expansions [<kind> (template.identifier [<type> "'"])] + (abstract: #export (<kind> kind) Any) + (`` (type: #export (<type> <brand>) (|> <brand> <kind> (~~ (template.splice <super>+))))))] + + [Var [Expression' Code]] + ) + + (template [<var> <kind>] + [(abstract: #export <kind> Any) + (type: #export <var> (Var <kind>))] + + [SVar Single] + [PVar Poly] + ) + + (def: #export var + (-> Text SVar) + (|>> :abstraction)) + + (def: #export var_args + PVar + (:abstraction "...")) + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (def: (self_contained code) + (-> Text Expression) + (:abstraction + (format "(" code ")"))) + + (def: nested_new_line + (format text.new_line text.tab)) + + (def: nest + (-> Text Text) + (|>> (text.replace_all text.new_line ..nested_new_line) + (format ..nested_new_line))) + + (def: (_block expression) + (-> Text Text) + (format "{" (nest expression) text.new_line "}")) + + (def: #export (block expression) + (-> Expression Expression) + (:abstraction + (format "{" + (..nest (:representation expression)) + text.new_line "}"))) + + (template [<name> <r>] + [(def: #export <name> + Expression + (:abstraction <r>))] + + [null "NULL"] + [n/a "NA"] + ) + + (template [<name>] + [(def: #export <name> Expression n/a)] + + [not_available] + [not_applicable] + [no_answer] + ) + + (def: #export bool + (-> Bit Expression) + (|>> (case> #0 "FALSE" + #1 "TRUE") + :abstraction)) + + (def: #export int + (-> Int Expression) + (|>> %.int :abstraction)) + + (def: #export float + (-> Frac Expression) + (|>> (cond> [(f.= f.positive_infinity)] + [(new> "1.0/0.0" [])] + + [(f.= f.negative_infinity)] + [(new> "-1.0/0.0" [])] + + [(f.= f.not_a_number)] + [(new> "0.0/0.0" [])] + + ## else + [%.frac]) + ..self_contained)) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [<find> <replace>] + [(text.replace_all <find> <replace>)] + + ["\" "\\"] + ["|" "\|"] + [text.alarm "\a"] + [text.back_space "\b"] + [text.tab "\t"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] + )) + ))) + + (def: #export string + (-> Text Expression) + (|>> ..sanitize %.text :abstraction)) + + (def: #export (slice from to list) + (-> Expression Expression Expression Expression) + (..self_contained + (format (:representation list) + "[" (:representation from) ":" (:representation to) "]"))) + + (def: #export (slice_from from list) + (-> Expression Expression Expression) + (..self_contained + (format (:representation list) + "[-1" ":-" (:representation from) "]"))) + + (def: #export (apply args func) + (-> (List Expression) Expression Expression) + (let [func (:representation func) + spacing (|> " " (list.repeat (text.size func)) (text.join_with ""))] + (:abstraction + (format func "(" + (|> args + (list\map ..code) + (text.join_with (format "," text.new_line)) + ..nest) + ")")))) + + (template [<name> <function>] + [(def: #export (<name> members) + (-> (List Expression) Expression) + (..apply members (..var <function>)))] + + [vector "c"] + [list "list"] + ) + + (def: #export named_list + (-> (List [Text Expression]) Expression) + (|>> (list\map (.function (_ [key value]) + (:abstraction (format key "=" (:representation value))))) + ..list)) + + (def: #export (apply_kw args kw_args func) + (-> (List Expression) (List [Text Expression]) Expression Expression) + (..self_contained + (format (:representation func) + (format "(" + (text.join_with "," (list\map ..code args)) "," + (text.join_with "," (list\map (.function (_ [key val]) + (format key "=" (:representation val))) + kw_args)) + ")")))) + + (syntax: (arity_inputs {arity <code>.nat}) + (wrap (case arity + 0 (.list) + _ (|> arity + list.indices + (list\map (|>> %.nat code.local_identifier)))))) + + (syntax: (arity_types {arity <code>.nat}) + (wrap (list.repeat arity (` ..Expression)))) + + (template [<arity> <function>+] + [(with_expansions [<apply> (template.identifier ["apply/" <arity>]) + <inputs> (arity_inputs <arity>) + <types> (arity_types <arity>) + <definitions> (template.splice <function>+)] + (def: #export (<apply> function [<inputs>]) + (-> Expression [<types>] Expression) + (..apply (.list <inputs>) function)) + + (template [<function>] + [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>])) + (-> [<types>] Expression) + (<apply> (..var <function>))))] + + <definitions>))] + + [0 + [["commandArgs"]]] + [1 + [["intToUtf8"]]] + [2 + [["paste"]]] + ) + + (def: #export as::integer + (-> Expression Expression) + (..apply/1 (..var "as.integer"))) + + (def: #export (nth idx list) + (-> Expression Expression Expression) + (..self_contained + (format (:representation list) "[[" (:representation idx) "]]"))) + + (def: #export (if test then else) + (-> Expression Expression Expression Expression) + (:abstraction + (format "if(" (:representation test) ")" + " " (.._block (:representation then)) + " else " (.._block (:representation else))))) + + (def: #export (when test then) + (-> Expression Expression Expression) + (:abstraction + (format "if(" (:representation test) ") {" + (.._block (:representation then)) + text.new_line "}"))) + + (def: #export (cond clauses else) + (-> (List [Expression Expression]) Expression Expression) + (list\fold (.function (_ [test then] next) + (if test then next)) + else + (list.reverse clauses))) + + (template [<name> <op>] + [(def: #export (<name> param subject) + (-> Expression Expression Expression) + (..self_contained + (format (:representation subject) + " " <op> " " + (:representation param))))] + + [= "=="] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + [+ "+"] + [- "-"] + [* "*"] + [/ "/"] + [%% "%%"] + [** "**"] + [or "||"] + [and "&&"] + ) + + (template [<name> <func>] + [(def: #export (<name> param subject) + (-> Expression Expression Expression) + (..apply (.list subject param) (..var <func>)))] + + [bit_or "bitwOr"] + [bit_and "bitwAnd"] + [bit_xor "bitwXor"] + [bit_shl "bitwShiftL"] + [bit_ushr "bitwShiftR"] + ) + + (def: #export (bit_not subject) + (-> Expression Expression) + (..apply (.list subject) (..var "bitwNot"))) + + (template [<name> <op>] + [(def: #export <name> + (-> Expression Expression) + (|>> :representation (format <op>) ..self_contained))] + + [not "!"] + [negate "-"] + ) + + (def: #export (length list) + (-> Expression Expression) + (..apply (.list list) (..var "length"))) + + (def: #export (range from to) + (-> Expression Expression Expression) + (..self_contained + (format (:representation from) ":" (:representation to)))) + + (def: #export (function inputs body) + (-> (List (Ex [k] (Var k))) Expression Expression) + (let [args (|> inputs (list\map ..code) (text.join_with ", "))] + (..self_contained + (format "function(" args ") " + (.._block (:representation body)))))) + + (def: #export (try body warning error finally) + (-> Expression (Maybe Expression) (Maybe Expression) (Maybe Expression) Expression) + (let [optional (: (-> Text (Maybe Expression) (-> Text Text) Text) + (.function (_ parameter value preparation) + (|> value + (maybe\map (|>> :representation preparation (format ", " parameter " = "))) + (maybe.default ""))))] + (..self_contained + (format "tryCatch(" + (.._block (:representation body)) + (optional "warning" warning function.identity) + (optional "error" error function.identity) + (optional "finally" finally .._block) + ")")))) + + (def: #export (while test body) + (-> Expression Expression Expression) + (..self_contained + (format "while (" (:representation test) ") " + (.._block (:representation body))))) + + (def: #export (for_in var inputs body) + (-> SVar Expression Expression Expression) + (..self_contained + (format "for (" (:representation var) " in " (:representation inputs) ")" + (.._block (:representation body))))) + + (template [<name> <keyword>] + [(def: #export (<name> message) + (-> Expression Expression) + (..apply (.list message) (..var <keyword>)))] + + [stop "stop"] + [print "print"] + ) + + (def: #export (set! var value) + (-> SVar Expression Expression) + (..self_contained + (format (:representation var) " <- " (:representation value)))) + + (def: #export (set_nth! idx value list) + (-> Expression Expression SVar Expression) + (..self_contained + (format (:representation list) "[[" (:representation idx) "]] <- " (:representation value)))) + + (def: #export (then pre post) + (-> Expression Expression Expression) + (:abstraction + (format (:representation pre) + text.new_line + (:representation post)))) + ) diff --git a/stdlib/source/library/lux/target/ruby.lux b/stdlib/source/library/lux/target/ruby.lux new file mode 100644 index 000000000..3eb4f07b9 --- /dev/null +++ b/stdlib/source/library/lux/target/ruby.lux @@ -0,0 +1,473 @@ +(.module: + [library + [lux (#- Location Code static int if cond function or and not comment) + ["@" target] + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + ["." enum]] + [control + [pipe (#+ case> cond> new>)] + [parser + ["<.>" code]]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [macro + [syntax (#+ syntax:)] + ["." template] + ["." code]] + [math + [number + ["n" nat] + ["f" frac]]] + [type + abstract]]]) + +(def: input_separator ", ") +(def: statement_suffix ";") + +(def: nest + (-> Text Text) + (.let [nested_new_line (format text.new_line text.tab)] + (|>> (format text.new_line) + (text.replace_all text.new_line nested_new_line)))) + +(abstract: #export (Code brand) + Text + + (implementation: #export code_equivalence + (All [brand] (Equivalence (Code brand))) + + (def: (= reference subject) + (\ text.equivalence = (:representation reference) (:representation subject)))) + + (implementation: #export code_hash + (All [brand] (Hash (Code brand))) + + (def: &equivalence ..code_equivalence) + (def: hash (|>> :representation (\ text.hash hash)))) + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (template [<type> <super>+] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (abstract: (<brand> brand) Any) + (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))] + + [Expression [Code]] + [Computation [Expression' Code]] + [Location [Computation' Expression' Code]] + [Var [Location' Computation' Expression' Code]] + [LVar [Var' Location' Computation' Expression' Code]] + [Statement [Code]] + ) + + (template [<type> <super>+] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (abstract: #export <brand> Any) + (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))] + + [Literal [Computation' Expression' Code]] + [Access [Location' Computation' Expression' Code]] + [GVar [Var' Location' Computation' Expression' Code]] + [IVar [Var' Location' Computation' Expression' Code]] + [SVar [Var' Location' Computation' Expression' Code]] + [LVar* [LVar' Var' Location' Computation' Expression' Code]] + [LVar** [LVar' Var' Location' Computation' Expression' Code]] + ) + + (template [<var> <prefix> <constructor>] + [(def: #export <constructor> + (-> Text <var>) + (|>> (format <prefix>) :abstraction))] + + [GVar "$" global] + [IVar "@" instance] + [SVar "@@" static] + ) + + (def: #export local + (-> Text LVar) + (|>> :abstraction)) + + (template [<var> <prefix> <modifier> <unpacker>] + [(template [<name> <input> <output>] + [(def: #export <name> + (-> <input> <output>) + (|>> :representation (format <prefix>) :abstraction))] + + [<modifier> LVar <var>] + [<unpacker> Expression Computation] + )] + + [LVar* "*" variadic splat] + [LVar** "**" variadic_kv double_splat] + ) + + (template [<ruby_name> <lux_name>] + [(def: #export <lux_name> + (..global <ruby_name>))] + + ["@" latest_error] + ["_" last_string_read] + ["." last_line_number_read] + ["&" last_string_matched] + ["~" last_regexp_match] + ["=" case_insensitivity_flag] + ["/" input_record_separator] + ["\" output_record_separator] + ["0" script_name] + ["$" process_id] + ["?" exit_status] + ) + + (template [<ruby_name> <lux_name>] + [(def: #export <lux_name> + (..local <ruby_name>))] + + ["ARGV" command_line_arguments] + ) + + (def: #export nil + Literal + (:abstraction "nil")) + + (def: #export bool + (-> Bit Literal) + (|>> (case> #0 "false" + #1 "true") + :abstraction)) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [<find> <replace>] + [(text.replace_all <find> <replace>)] + + ["\" "\\"] + [text.tab "\t"] + [text.vertical_tab "\v"] + [text.null "\0"] + [text.back_space "\b"] + [text.form_feed "\f"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] + )) + ))) + + (template [<format> <name> <type> <prep>] + [(def: #export <name> + (-> <type> Literal) + (|>> <prep> <format> :abstraction))] + + [%.int int Int (<|)] + [%.text string Text ..sanitize] + [(<|) symbol Text (format ":")] + ) + + (def: #export float + (-> Frac Literal) + (|>> (cond> [(f.= f.positive_infinity)] + [(new> "(+1.0/0.0)" [])] + + [(f.= f.negative_infinity)] + [(new> "(-1.0/0.0)" [])] + + [(f.= f.not_a_number)] + [(new> "(+0.0/-0.0)" [])] + + ## else + [%.frac]) + :abstraction)) + + (def: #export (array_range from to array) + (-> Expression Expression Expression Computation) + (|> (format (:representation from) ".." (:representation to)) + (text.enclose ["[" "]"]) + (format (:representation array)) + :abstraction)) + + (def: #export array + (-> (List Expression) Literal) + (|>> (list\map (|>> :representation)) + (text.join_with ..input_separator) + (text.enclose ["[" "]"]) + :abstraction)) + + (def: #export hash + (-> (List [Expression Expression]) Literal) + (|>> (list\map (.function (_ [k v]) + (format (:representation k) " => " (:representation v)))) + (text.join_with ..input_separator) + (text.enclose ["{" "}"]) + :abstraction)) + + (def: #export (apply/* args func) + (-> (List Expression) Expression Computation) + (|> args + (list\map (|>> :representation)) + (text.join_with ..input_separator) + (text.enclose ["(" ")"]) + (format (:representation func)) + :abstraction)) + + (def: #export (apply_lambda/* args lambda) + (-> (List Expression) Expression Computation) + (|> args + (list\map (|>> :representation)) + (text.join_with ..input_separator) + (text.enclose ["[" "]"]) + (format (:representation lambda)) + :abstraction)) + + (def: #export (the field object) + (-> Text Expression Access) + (:abstraction (format (:representation object) "." field))) + + (def: #export (nth idx array) + (-> Expression Expression Access) + (|> (:representation idx) + (text.enclose ["[" "]"]) + (format (:representation array)) + :abstraction)) + + (def: #export (? test then else) + (-> Expression Expression Expression Computation) + (|> (format (:representation test) " ? " + (:representation then) " : " + (:representation else)) + (text.enclose ["(" ")"]) + :abstraction)) + + (def: #export statement + (-> Expression Statement) + (|>> :representation + (text.suffix ..statement_suffix) + :abstraction)) + + (def: #export (then pre! post!) + (-> Statement Statement Statement) + (:abstraction + (format (:representation pre!) + text.new_line + (:representation post!)))) + + (def: #export (set vars value) + (-> (List Location) Expression Statement) + (:abstraction + (format (|> vars + (list\map (|>> :representation)) + (text.join_with ..input_separator)) + " = " (:representation value) ..statement_suffix))) + + (def: (block content) + (-> Text Text) + (format content + text.new_line "end" ..statement_suffix)) + + (def: #export (if test then! else!) + (-> Expression Statement Statement Statement) + (<| :abstraction + ..block + (format "if " (:representation test) + (..nest (:representation then!)) + text.new_line "else" + (..nest (:representation else!))))) + + (template [<name> <block>] + [(def: #export (<name> test then!) + (-> Expression Statement Statement) + (<| :abstraction + ..block + (format <block> " " (:representation test) + (..nest (:representation then!)))))] + + [when "if"] + [while "while"] + ) + + (def: #export (for_in var array iteration!) + (-> LVar Expression Statement Statement) + (<| :abstraction + ..block + (format "for " (:representation var) + " in " (:representation array) + " do " + (..nest (:representation iteration!))))) + + (type: #export Rescue + {#classes (List Text) + #exception LVar + #rescue Statement}) + + (def: #export (begin body! rescues) + (-> Statement (List Rescue) Statement) + (<| :abstraction + ..block + (format "begin" (..nest (:representation body!)) + (|> rescues + (list\map (.function (_ [classes exception rescue]) + (format text.new_line "rescue " (text.join_with ..input_separator classes) + " => " (:representation exception) + (..nest (:representation rescue))))) + (text.join_with text.new_line))))) + + (def: #export (catch expectation body!) + (-> Expression Statement Statement) + (<| :abstraction + ..block + (format "catch(" (:representation expectation) ") do" + (..nest (:representation body!))))) + + (def: #export (return value) + (-> Expression Statement) + (:abstraction (format "return " (:representation value) ..statement_suffix))) + + (def: #export (raise message) + (-> Expression Computation) + (:abstraction (format "raise " (:representation message)))) + + (template [<name> <keyword>] + [(def: #export <name> + Statement + (|> <keyword> + (text.suffix ..statement_suffix) + :abstraction))] + + [next "next"] + [redo "redo"] + [break "break"] + ) + + (def: #export (function name args body!) + (-> LVar (List LVar) Statement Statement) + (<| :abstraction + ..block + (format "def " (:representation name) + (|> args + (list\map (|>> :representation)) + (text.join_with ..input_separator) + (text.enclose ["(" ")"])) + (..nest (:representation body!))))) + + (def: #export (lambda name args body!) + (-> (Maybe LVar) (List Var) Statement Literal) + (let [proc (|> (format (|> args + (list\map (|>> :representation)) + (text.join_with ..input_separator) + (text.enclose' "|")) + (..nest (:representation body!))) + (text.enclose ["{" "}"]) + (format "lambda "))] + (|> (case name + #.None + proc + + (#.Some name) + (format (:representation name) " = " proc)) + (text.enclose ["(" ")"]) + :abstraction))) + + (template [<op> <name>] + [(def: #export (<name> parameter subject) + (-> Expression Expression Computation) + (:abstraction (format "(" (:representation subject) " " <op> " " (:representation parameter) ")")))] + + ["==" =] + [ "<" <] + ["<=" <=] + [ ">" >] + [">=" >=] + + [ "+" +] + [ "-" -] + [ "*" *] + [ "/" /] + [ "%" %] + ["**" pow] + + ["||" or] + ["&&" and] + [ "|" bit_or] + [ "&" bit_and] + [ "^" bit_xor] + + ["<<" bit_shl] + [">>" bit_shr] + ) + + (template [<unary> <name>] + [(def: #export (<name> subject) + (-> Expression Computation) + (:abstraction (format "(" <unary> (:representation subject) ")")))] + + ["!" not] + ["-" negate] + ) + + (def: #export (comment commentary on) + (All [brand] (-> Text (Code brand) (Code brand))) + (:abstraction (format "# " (..sanitize commentary) text.new_line + (:representation on)))) + ) + +(def: #export (do method args object) + (-> Text (List Expression) Expression Computation) + (|> object (..the method) (..apply/* args))) + +(def: #export (cond clauses else!) + (-> (List [Expression Statement]) Statement Statement) + (list\fold (.function (_ [test then!] next!) + (..if test then! next!)) + else! + (list.reverse clauses))) + +(syntax: (arity_inputs {arity <code>.nat}) + (wrap (case arity + 0 (.list) + _ (|> (dec arity) + (enum.range n.enum 0) + (list\map (|>> %.nat code.local_identifier)))))) + +(syntax: (arity_types {arity <code>.nat}) + (wrap (list.repeat arity (` ..Expression)))) + +(template [<arity> <function>+] + [(with_expansions [<apply> (template.identifier ["apply/" <arity>]) + <inputs> (arity_inputs <arity>) + <types> (arity_types <arity>) + <definitions> (template.splice <function>+)] + (def: #export (<apply> function <inputs>) + (-> Expression <types> Computation) + (..apply/* (.list <inputs>) function)) + + (template [<function>] + [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>])) + (<apply> (..local <function>))))] + + <definitions>))] + + [1 + [["print"] + ["require"]]] + + [2 + [["print"]]] + + [3 + [["print"]]] + ) + +(def: #export throw/1 + (-> Expression Statement) + (|>> (..apply/1 (..local "throw")) + ..statement)) diff --git a/stdlib/source/library/lux/target/scheme.lux b/stdlib/source/library/lux/target/scheme.lux new file mode 100644 index 000000000..8e1308e04 --- /dev/null +++ b/stdlib/source/library/lux/target/scheme.lux @@ -0,0 +1,380 @@ +(.module: + [library + [lux (#- Code int or and if cond let) + ["@" target] + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] + [control + [pipe (#+ new> cond> case>)]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold monoid)]]] + [macro + ["." template]] + [math + [number + ["n" nat] + ["f" frac]]] + [type + abstract]]]) + +(def: nest + (-> Text Text) + (.let [nested_new_line (format text.new_line text.tab)] + (text.replace_all text.new_line nested_new_line))) + +(abstract: #export (Code k) + Text + + (implementation: #export equivalence + (All [brand] (Equivalence (Code brand))) + + (def: (= reference subject) + (\ text.equivalence = (:representation reference) (:representation subject)))) + + (implementation: #export hash + (All [brand] (Hash (Code brand))) + + (def: &equivalence ..equivalence) + (def: hash (|>> :representation (\ text.hash hash)))) + + (template [<type> <brand> <super>+] + [(abstract: #export (<brand> brand) Any) + (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+)))))] + + [Expression Expression' [Code]] + ) + + (template [<type> <brand> <super>+] + [(abstract: #export <brand> Any) + (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+)))))] + + [Var Var' [Expression' Code]] + [Computation Computation' [Expression' Code]] + ) + + (type: #export Arguments + {#mandatory (List Var) + #rest (Maybe Var)}) + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (def: #export var + (-> Text Var) + (|>> :abstraction)) + + (def: (arguments [mandatory rest]) + (-> Arguments (Code Any)) + (case rest + (#.Some rest) + (case mandatory + #.Nil + rest + + _ + (|> (format " . " (:representation rest)) + (format (|> mandatory + (list\map ..code) + (text.join_with " "))) + (text.enclose ["(" ")"]) + :abstraction)) + + #.None + (|> mandatory + (list\map ..code) + (text.join_with " ") + (text.enclose ["(" ")"]) + :abstraction))) + + (def: #export nil + Computation + (:abstraction "'()")) + + (def: #export bool + (-> Bit Computation) + (|>> (case> #0 "#f" + #1 "#t") + :abstraction)) + + (def: #export int + (-> Int Computation) + (|>> %.int :abstraction)) + + (def: #export float + (-> Frac Computation) + (|>> (cond> [(f.= f.positive_infinity)] + [(new> "+inf.0" [])] + + [(f.= f.negative_infinity)] + [(new> "-inf.0" [])] + + [f.not_a_number?] + [(new> "+nan.0" [])] + + ## else + [%.frac]) + :abstraction)) + + (def: #export positive_infinity Computation (..float f.positive_infinity)) + (def: #export negative_infinity Computation (..float f.negative_infinity)) + (def: #export not_a_number Computation (..float f.not_a_number)) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [<find> <replace>] + [(text.replace_all <find> <replace>)] + + ["\" "\\"] + ["|" "\|"] + [text.alarm "\a"] + [text.back_space "\b"] + [text.tab "\t"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] + )) + ))) + + (def: #export string + (-> Text Computation) + (|>> ..sanitize %.text :abstraction)) + + (def: #export symbol + (-> Text Computation) + (|>> (format "'") :abstraction)) + + (def: form + (-> (List (Code Any)) Code) + (.let [nested_new_line (format text.new_line text.tab)] + (|>> (case> #.Nil + (:abstraction "()") + + (#.Cons head tail) + (|> tail + (list\map (|>> :representation nest)) + (#.Cons (:representation head)) + (text.join_with nested_new_line) + (text.enclose ["(" ")"]) + :abstraction))))) + + (def: #export (apply/* args func) + (-> (List Expression) Expression Computation) + (..form (#.Cons func args))) + + (template [<name> <function>] + [(def: #export (<name> members) + (-> (List Expression) Computation) + (..apply/* members (..var <function>)))] + + [vector/* "vector"] + [list/* "list"] + ) + + (def: #export apply/0 + (-> Expression Computation) + (..apply/* (list))) + + (template [<lux_name> <scheme_name>] + [(def: #export <lux_name> + (apply/0 (..var <scheme_name>)))] + + [newline/0 "newline"] + ) + + (template [<apply> <arg>+ <type>+ <function>+] + [(`` (def: #export (<apply> procedure) + (-> Expression (~~ (template.splice <type>+)) Computation) + (function (_ (~~ (template.splice <arg>+))) + (..apply/* (list (~~ (template.splice <arg>+))) procedure)))) + + (`` (template [<definition> <function>] + [(def: #export <definition> (<apply> (..var <function>)))] + + (~~ (template.splice <function>+))))] + + [apply/1 [_0] [Expression] + [[exact/1 "exact"] + [integer->char/1 "integer->char"] + [char->integer/1 "char->integer"] + [number->string/1 "number->string"] + [string->number/1 "string->number"] + [floor/1 "floor"] + [truncate/1 "truncate"] + [string/1 "string"] + [string?/1 "string?"] + [length/1 "length"] + [values/1 "values"] + [null?/1 "null?"] + [car/1 "car"] + [cdr/1 "cdr"] + [raise/1 "raise"] + [error-object-message/1 "error-object-message"] + [make-vector/1 "make-vector"] + [vector-length/1 "vector-length"] + [not/1 "not"] + [string-hash/1 "string-hash"] + [reverse/1 "reverse"] + [display/1 "display"] + [exit/1 "exit"] + [string-length/1 "string-length"] + [load-relative/1 "load-relative"]]] + + [apply/2 [_0 _1] [Expression Expression] + [[append/2 "append"] + [cons/2 "cons"] + [make-vector/2 "make-vector"] + ## [vector-ref/2 "vector-ref"] + [list-tail/2 "list-tail"] + [map/2 "map"] + [string-ref/2 "string-ref"] + [string-append/2 "string-append"] + [make-string/2 "make-string"]]] + + [apply/3 [_0 _1 _2] [Expression Expression Expression] + [[substring/3 "substring"] + [vector-set!/3 "vector-set!"] + [string-contains/3 "string-contains"]]] + + [apply/5 [_0 _1 _2 _3 _4] [Expression Expression Expression Expression Expression] + [[vector-copy!/5 "vector-copy!"]]] + ) + + ## TODO: define "vector-ref/2" like a normal apply/2 function. + ## "vector-ref/2" as an 'invoke' is problematic, since it only works + ## in Kawa. + ## However, the way Kawa defines "vector-ref" causes trouble, + ## because it does a runtime type-check which throws an error when + ## it checks against custom values/objects/classes made for + ## JVM<->Scheme interop. + ## There are 2 ways to deal with this: + ## 0. To fork Kawa, and get rid of the type-check so the normal + ## "vector-ref" can be used instead. + ## 1. To carry on, and then, when it's time to compile the compiler + ## itself into Scheme, switch from 'invoke' to normal 'vector-ref'. + ## Either way, the 'invoke' needs to go away. + (def: #export (vector-ref/2 vector index) + (-> Expression Expression Computation) + (..form (list (..var "invoke") vector (..symbol "getRaw") index))) + + (template [<lux_name> <scheme_name>] + [(def: #export (<lux_name> param subject) + (-> Expression Expression Computation) + (..apply/2 (..var <scheme_name>) subject param))] + + [=/2 "="] + [eq?/2 "eq?"] + [eqv?/2 "eqv?"] + [</2 "<"] + [<=/2 "<="] + [>/2 ">"] + [>=/2 ">="] + [string=?/2 "string=?"] + [string<?/2 "string<?"] + [+/2 "+"] + [-/2 "-"] + [//2 "/"] + [*/2 "*"] + [expt/2 "expt"] + [remainder/2 "remainder"] + [quotient/2 "quotient"] + [mod/2 "mod"] + [arithmetic-shift/2 "arithmetic-shift"] + [bitwise-and/2 "bitwise-and"] + [bitwise-ior/2 "bitwise-ior"] + [bitwise-xor/2 "bitwise-xor"] + ) + + (template [<lux_name> <scheme_name>] + [(def: #export <lux_name> + (-> (List Expression) Computation) + (|>> (list& (..var <scheme_name>)) ..form))] + + [or "or"] + [and "and"] + ) + + (template [<lux_name> <scheme_name> <var> <pre>] + [(def: #export (<lux_name> bindings body) + (-> (List [<var> Expression]) Expression Computation) + (..form (list (..var <scheme_name>) + (|> bindings + (list\map (function (_ [binding/name binding/value]) + (..form (list (|> binding/name <pre>) + binding/value)))) + ..form) + body)))] + + [let "let" Var (<|)] + [let* "let*" Var (<|)] + [letrec "letrec" Var (<|)] + [let_values "let-values" Arguments ..arguments] + [let*_values "let*-values" Arguments ..arguments] + [letrec_values "letrec-values" Arguments ..arguments] + ) + + (def: #export (if test then else) + (-> Expression Expression Expression Computation) + (..form (list (..var "if") test then else))) + + (def: #export (when test then) + (-> Expression Expression Computation) + (..form (list (..var "when") test then))) + + (def: #export (lambda arguments body) + (-> Arguments Expression Computation) + (..form (list (..var "lambda") + (..arguments arguments) + body))) + + (def: #export (define_function name arguments body) + (-> Var Arguments Expression Computation) + (..form (list (..var "define") + (|> arguments + (update@ #mandatory (|>> (#.Cons name))) + ..arguments) + body))) + + (def: #export (define_constant name value) + (-> Var Expression Computation) + (..form (list (..var "define") name value))) + + (def: #export begin + (-> (List Expression) Computation) + (|>> (#.Cons (..var "begin")) ..form)) + + (def: #export (set! name value) + (-> Var Expression Computation) + (..form (list (..var "set!") name value))) + + (def: #export (with_exception_handler handler body) + (-> Expression Expression Computation) + (..form (list (..var "with-exception-handler") handler body))) + + (def: #export (call_with_current_continuation body) + (-> Expression Computation) + (..form (list (..var "call-with-current-continuation") body))) + + (def: #export (guard variable clauses else body) + (-> Var (List [Expression Expression]) (Maybe Expression) Expression Computation) + (..form (list (..var "guard") + (..form (|> (case else + #.None + (list) + + (#.Some else) + (list (..form (list (..var "else") else)))) + (list\compose (list\map (function (_ [when then]) + (..form (list when then))) + clauses)) + (list& variable))) + body))) + ) diff --git a/stdlib/source/library/lux/test.lux b/stdlib/source/library/lux/test.lux new file mode 100644 index 000000000..6e28624ce --- /dev/null +++ b/stdlib/source/library/lux/test.lux @@ -0,0 +1,419 @@ +(.module: {#.doc "Tools for unit & property-based/generative testing."} + [library + [lux (#- and for) + ["." meta] + ["." debug] + [abstract + ["." monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." try] + ["." exception (#+ exception:)] + ["." io] + [concurrency + ["." atom (#+ Atom)] + ["." promise (#+ Promise) ("#\." monad)]] + ["<>" parser + ["<.>" code]]] + [data + ["." maybe] + ["." product] + ["." name] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set (#+ Set)] + ["." dictionary #_ + ["#" ordered (#+ Dictionary)]]]] + [time + ["." instant] + ["." duration (#+ Duration)]] + [math + ["." random (#+ Random) ("#\." monad)] + [number (#+ hex) + ["n" nat] + ["f" frac]]] + [macro + [syntax (#+ syntax:)] + ["." code]] + [world + ["." program]]]]) + +(type: #export Tally + {#successes Nat + #failures Nat + #expected_coverage (Set Name) + #actual_coverage (Set Name)}) + +(def: (add_tally parameter subject) + (-> Tally Tally Tally) + {#successes (n.+ (get@ #successes parameter) (get@ #successes subject)) + #failures (n.+ (get@ #failures parameter) (get@ #failures subject)) + #expected_coverage (set.union (get@ #expected_coverage parameter) + (get@ #expected_coverage subject)) + #actual_coverage (set.union (get@ #actual_coverage parameter) + (get@ #actual_coverage subject))}) + +(def: start + Tally + {#successes 0 + #failures 0 + #expected_coverage (set.new name.hash) + #actual_coverage (set.new name.hash)}) + +(template [<name> <category>] + [(def: <name> + Tally + (update@ <category> .inc ..start))] + + [success #successes] + [failure #failures] + ) + +(type: #export Assertion + (Promise [Tally Text])) + +(type: #export Test + (Random Assertion)) + +(def: separator + text.new_line) + +(def: #export (and' left right) + {#.doc "Sequencing combinator."} + (-> Assertion Assertion Assertion) + (let [[read! write!] (: [(Promise [Tally Text]) + (promise.Resolver [Tally Text])] + (promise.promise [])) + _ (|> left + (promise.await (function (_ [l_tally l_documentation]) + (promise.await (function (_ [r_tally r_documentation]) + (write! [(add_tally l_tally r_tally) + (format l_documentation ..separator r_documentation)])) + right))) + io.run)] + read!)) + +(def: #export (and left right) + {#.doc "Sequencing combinator."} + (-> Test Test Test) + (do {! random.monad} + [left left] + (\ ! map (..and' left) right))) + +(def: context_prefix + text.tab) + +(def: #export (context description) + (-> Text Test Test) + (random\map (promise\map (function (_ [tally documentation]) + [tally (|> documentation + (text.split_all_with ..separator) + (list\map (|>> (format context_prefix))) + (text.join_with ..separator) + (format description ..separator))])))) + +(def: failure_prefix "[Failure] ") +(def: success_prefix "[Success] ") + +(def: #export fail + (-> Text Test) + (|>> (format ..failure_prefix) + [..failure] + promise\wrap + random\wrap)) + +(def: #export (assert message condition) + {#.doc "Check that a condition is #1, and fail with the given message otherwise."} + (-> Text Bit Assertion) + (<| promise\wrap + (if condition + [..success (format ..success_prefix message)] + [..failure (format ..failure_prefix message)]))) + +(def: #export (test message condition) + {#.doc "Check that a condition is #1, and fail with the given message otherwise."} + (-> Text Bit Test) + (random\wrap (..assert message condition))) + +(def: #export (lift message random) + (-> Text (Random Bit) Test) + (random\map (..assert message) random)) + +(def: pcg32_magic_inc + Nat + (hex "FEDCBA9876543210")) + +(type: #export Seed + {#.doc "The seed value used for random testing (if that feature is used)."} + Nat) + +(def: #export (seed value test) + (-> Seed Test Test) + (function (_ prng) + (let [[_ result] (random.run (random.pcg32 [..pcg32_magic_inc value]) + test)] + [prng result]))) + +(def: failed? + (-> Tally Bit) + (|>> (get@ #failures) (n.> 0))) + +(def: (times_failure seed documentation) + (-> Seed Text Text) + (format documentation ..separator ..separator + "Failed with this seed: " (%.nat seed))) + +(exception: #export must_try_test_at_least_once) + +(def: #export (times amount test) + (-> Nat Test Test) + (case amount + 0 (..fail (exception.construct ..must_try_test_at_least_once [])) + _ (do random.monad + [seed random.nat] + (function (recur prng) + (let [[prng' instance] (random.run (random.pcg32 [..pcg32_magic_inc seed]) test)] + [prng' (do {! promise.monad} + [[tally documentation] instance] + (if (..failed? tally) + (wrap [tally (times_failure seed documentation)]) + (case amount + 1 instance + _ (|> test + (times (dec amount)) + (random.run prng') + product.right))))]))))) + +(def: (description duration tally) + (-> Duration Tally Text) + (let [successes (get@ #successes tally) + failures (get@ #failures tally) + missing (set.difference (get@ #actual_coverage tally) + (get@ #expected_coverage tally)) + unexpected (set.difference (get@ #expected_coverage tally) + (get@ #actual_coverage tally)) + report (: (-> (Set Name) Text) + (|>> set.to_list + (list.sort (\ name.order <)) + (exception.enumerate %.name))) + expected_definitions_to_cover (set.size (get@ #expected_coverage tally)) + unexpected_definitions_covered (set.size unexpected) + actual_definitions_covered (n.- unexpected_definitions_covered + (set.size (get@ #actual_coverage tally))) + coverage (case expected_definitions_to_cover + 0 "N/A" + expected (let [missing_ratio (f./ (n.frac expected) + (n.frac (set.size missing))) + max_percent +100.0 + done_percent (|> +1.0 + (f.- missing_ratio) + (f.* max_percent))] + (if (f.= max_percent done_percent) + "100%" + (let [raw (|> done_percent + %.frac + (text.replace_once "+" ""))] + (|> raw + (text.clip 0 (if (f.>= +10.0 done_percent) + 5 ## XX.XX + 4 ## X.XX + )) + (maybe.default raw) + (text.suffix "%"))))))] + (exception.report + ["Duration" (%.duration duration)] + ["# Tests" (%.nat (n.+ successes failures))] + ["# Successes" (%.nat successes)] + ["# Failures" (%.nat failures)] + ["# Expected definitions to cover" (%.nat expected_definitions_to_cover)] + ["# Actual definitions covered" (%.nat actual_definitions_covered)] + ["# Pending definitions to cover" (%.nat (n.- actual_definitions_covered + expected_definitions_to_cover))] + ["# Unexpected definitions covered" (%.nat unexpected_definitions_covered)] + ["Coverage" coverage] + ["Pending definitions to cover" (report missing)] + ["Unexpected definitions covered" (report unexpected)]))) + +(def: failure_exit_code +1) +(def: success_exit_code +0) + +(def: #export (run! test) + (-> Test (Promise Nothing)) + (do promise.monad + [pre (promise.future instant.now) + #let [seed (instant.to_millis pre) + prng (random.pcg32 [..pcg32_magic_inc seed])] + [tally documentation] (|> test (random.run prng) product.right) + post (promise.future instant.now) + #let [duration (instant.span pre post) + _ (debug.log! (format documentation text.new_line text.new_line + (..description duration tally) + text.new_line))]] + (promise.future (\ program.default exit + (case (get@ #failures tally) + 0 ..success_exit_code + _ ..failure_exit_code))))) + +(def: (|cover'| coverage condition) + (-> (List Name) Bit Assertion) + (let [message (|> coverage + (list\map %.name) + (text.join_with " & ")) + coverage (set.from_list name.hash coverage)] + (|> (..assert message condition) + (promise\map (function (_ [tally documentation]) + [(update@ #actual_coverage (set.union coverage) tally) + documentation]))))) + +(def: (|cover| coverage condition) + (-> (List Name) Bit Test) + (|> (..|cover'| coverage condition) + random\wrap)) + +(def: (|for| coverage test) + (-> (List Name) Test Test) + (let [context (|> coverage + (list\map %.name) + (text.join_with " & ")) + coverage (set.from_list name.hash coverage)] + (random\map (promise\map (function (_ [tally documentation]) + [(update@ #actual_coverage (set.union coverage) tally) + documentation])) + (..context context test)))) + +(def: (name_code name) + (-> Name Code) + (code.tuple (list (code.text (name.module name)) + (code.text (name.short name))))) + +(syntax: (reference {name <code>.identifier}) + (do meta.monad + [_ (meta.find_export name)] + (wrap (list (name_code name))))) + +(def: coverage_separator + Text + (text.from_code 31)) + +(def: encode_coverage + (-> (List Text) Text) + (list\fold (function (_ short aggregate) + (case aggregate + "" short + _ (format aggregate ..coverage_separator short))) + "")) + +(def: (decode_coverage module encoding) + (-> Text Text (Set Name)) + (loop [remaining encoding + output (set.from_list name.hash (list))] + (case (text.split_with ..coverage_separator remaining) + (#.Some [head tail]) + (recur tail (set.add [module head] output)) + + #.None + (set.add [module remaining] output)))) + +(template [<macro> <function>] + [(syntax: #export (<macro> {coverage (<code>.tuple (<>.many <code>.any))} + condition) + (let [coverage (list\map (function (_ definition) + (` ((~! ..reference) (~ definition)))) + coverage)] + (wrap (list (` ((~! <function>) + (: (.List .Name) + (.list (~+ coverage))) + (~ condition)))))))] + + [cover' ..|cover'|] + [cover ..|cover|] + ) + +(syntax: #export (for {coverage (<code>.tuple (<>.many <code>.any))} + test) + (let [coverage (list\map (function (_ definition) + (` ((~! ..reference) (~ definition)))) + coverage)] + (wrap (list (` ((~! ..|for|) + (: (.List .Name) + (.list (~+ coverage))) + (~ test))))))) + +(def: (covering' module coverage test) + (-> Text Text Test Test) + (let [coverage (..decode_coverage module coverage)] + (|> (..context module test) + (random\map (promise\map (function (_ [tally documentation]) + [(update@ #expected_coverage (set.union coverage) tally) + documentation])))))) + +(syntax: #export (covering {module <code>.identifier} + test) + (do meta.monad + [#let [module (name.module module)] + definitions (meta.definitions module) + #let [coverage (|> definitions + (list\fold (function (_ [short [exported? _]] aggregate) + (if exported? + (#.Cons short aggregate) + aggregate)) + #.Nil) + ..encode_coverage)]] + (wrap (list (` ((~! ..covering') + (~ (code.text module)) + (~ (code.text coverage)) + (~ test))))))) + +(exception: #export (error_during_execution {error Text}) + (exception.report + ["Error" (%.text error)])) + +(def: #export (in_parallel tests) + (-> (List Test) Test) + (case (list.size tests) + 0 + (random\wrap (promise\wrap [..start ""])) + + expected_tests + (do random.monad + [seed random.nat + #let [prng (random.pcg32 [..pcg32_magic_inc seed]) + run! (: (-> Test Assertion) + (|>> (random.run prng) + product.right + (function (_ _)) + "lux try" + (case> (#try.Success output) + output + + (#try.Failure error) + (..assert (exception.construct ..error_during_execution [error]) false)) + io.io + promise.future + promise\join)) + state (: (Atom (Dictionary Nat [Tally Text])) + (atom.atom (dictionary.new n.order))) + [read! write!] (: [Assertion + (promise.Resolver [Tally Text])] + (promise.promise [])) + _ (io.run (monad.map io.monad + (function (_ [index test]) + (promise.await (function (_ assertion) + (do io.monad + [[_ results] (atom.update (dictionary.put index assertion) state)] + (if (n.= expected_tests (dictionary.size results)) + (let [assertions (|> results + dictionary.entries + (list\map product.right))] + (write! [(|> assertions + (list\map product.left) + (list\fold ..add_tally ..start)) + (|> assertions + (list\map product.right) + (text.join_with ..separator))])) + (wrap [])))) + (run! test))) + (list.enumeration tests)))]] + (wrap read!)))) diff --git a/stdlib/source/library/lux/time.lux b/stdlib/source/library/lux/time.lux new file mode 100644 index 000000000..5c043f696 --- /dev/null +++ b/stdlib/source/library/lux/time.lux @@ -0,0 +1,217 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [enum (#+ Enum)] + [codec (#+ Codec)] + [monad (#+ Monad do)]] + [control + [pipe (#+ case>)] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" text (#+ Parser)]]] + [data + ["." text ("#\." monoid)]] + [math + [number + ["n" nat ("#\." decimal)]]] + [type + abstract]]] + [/ + ["." duration (#+ Duration)]]) + +(template [<name> <singular> <plural>] + [(def: #export <name> + Nat + (.nat (duration.query <singular> <plural>)))] + + [milli_seconds duration.milli_second duration.second] + [seconds duration.second duration.minute] + [minutes duration.minute duration.hour] + [hours duration.hour duration.day] + ) + +(def: limit + Nat + (.nat (duration.to_millis duration.day))) + +(exception: #export (time_exceeds_a_day {time Nat}) + (exception.report + ["Time (in milli-seconds)" (n\encode time)] + ["Maximum (in milli-seconds)" (n\encode (dec limit))])) + +(def: separator ":") + +(def: parse_section + (Parser Nat) + (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))) + +(def: parse_millis + (Parser Nat) + (<>.either (|> (<text>.at_most 3 <text>.decimal) + (<>.codec n.decimal) + (<>.after (<text>.this "."))) + (\ <>.monad wrap 0))) + +(template [<maximum> <parser> <exception> <sub_parser>] + [(exception: #export (<exception> {value Nat}) + (exception.report + ["Value" (n\encode value)] + ["Minimum" (n\encode 0)] + ["Maximum" (n\encode (dec <maximum>))])) + + (def: <parser> + (Parser Nat) + (do <>.monad + [value <sub_parser>] + (if (n.< <maximum> value) + (wrap value) + (<>.lift (exception.throw <exception> [value])))))] + + [..hours parse_hour invalid_hour ..parse_section] + [..minutes parse_minute invalid_minute ..parse_section] + [..seconds parse_second invalid_second ..parse_section] + ) + +(abstract: #export Time + Nat + + {#.doc "Time is defined as milliseconds since the start of the day (00:00:00.000)."} + + (def: #export midnight + {#.doc "The instant corresponding to the start of the day: 00:00:00.000"} + Time + (:abstraction 0)) + + (def: #export (from_millis milli_seconds) + (-> Nat (Try Time)) + (if (n.< ..limit milli_seconds) + (#try.Success (:abstraction milli_seconds)) + (exception.throw ..time_exceeds_a_day [milli_seconds]))) + + (def: #export to_millis + (-> Time Nat) + (|>> :representation)) + + (implementation: #export equivalence + (Equivalence Time) + + (def: (= param subject) + (n.= (:representation param) (:representation subject)))) + + (implementation: #export order + (Order Time) + + (def: &equivalence ..equivalence) + + (def: (< param subject) + (n.< (:representation param) (:representation subject)))) + + (`` (implementation: #export enum + (Enum Time) + + (def: &order ..order) + + (def: succ + (|>> :representation inc (n.% ..limit) :abstraction)) + + (def: pred + (|>> :representation + (case> 0 ..limit + millis millis) + dec + :abstraction)))) + + (def: #export parser + (Parser Time) + (let [to_millis (: (-> Duration Nat) + (|>> duration.to_millis .nat)) + hour (to_millis duration.hour) + minute (to_millis duration.minute) + second (to_millis duration.second) + millis (to_millis duration.milli_second)] + (do {! <>.monad} + [utc_hour ..parse_hour + _ (<text>.this ..separator) + utc_minute ..parse_minute + _ (<text>.this ..separator) + utc_second ..parse_second + utc_millis ..parse_millis] + (wrap (:abstraction + ($_ n.+ + (n.* utc_hour hour) + (n.* utc_minute minute) + (n.* utc_second second) + (n.* utc_millis millis))))))) + ) + +(def: (pad value) + (-> Nat Text) + (if (n.< 10 value) + (text\compose "0" (n\encode value)) + (n\encode value))) + +(def: (adjust_negative space duration) + (-> Duration Duration Duration) + (if (duration.negative? duration) + (duration.merge space duration) + duration)) + +(def: (encode_millis millis) + (-> Nat Text) + (cond (n.= 0 millis) "" + (n.< 10 millis) ($_ text\compose ".00" (n\encode millis)) + (n.< 100 millis) ($_ text\compose ".0" (n\encode millis)) + ## (n.< 1,000 millis) + ($_ text\compose "." (n\encode millis)))) + +(type: #export Clock + {#hour Nat + #minute Nat + #second Nat + #milli_second Nat}) + +(def: #export (clock time) + (-> Time Clock) + (let [time (|> time ..to_millis .int duration.from_millis) + [hours time] [(duration.query duration.hour time) (duration.frame duration.hour time)] + [minutes time] [(duration.query duration.minute time) (duration.frame duration.minute time)] + [seconds millis] [(duration.query duration.second time) (duration.frame duration.second time)]] + {#hour (.nat hours) + #minute (.nat minutes) + #second (.nat seconds) + #milli_second (|> millis + (..adjust_negative duration.second) + duration.to_millis + .nat)})) + +(def: #export (time clock) + (-> Clock (Try Time)) + (|> ($_ duration.merge + (duration.up (get@ #hour clock) duration.hour) + (duration.up (get@ #minute clock) duration.minute) + (duration.up (get@ #second clock) duration.second) + (duration.from_millis (.int (get@ #milli_second clock)))) + duration.to_millis + .nat + ..from_millis)) + +(def: (encode time) + (-> Time Text) + (let [(^slots [#hour #minute #second #milli_second]) (..clock time)] + ($_ text\compose + (..pad hour) + ..separator (..pad minute) + ..separator (..pad second) + (..encode_millis milli_second)))) + +(implementation: #export codec + {#.doc (doc "Based on ISO 8601." + "For example: 21:14:51.827")} + (Codec Text Time) + + (def: encode ..encode) + (def: decode (<text>.run ..parser))) diff --git a/stdlib/source/library/lux/time/date.lux b/stdlib/source/library/lux/time/date.lux new file mode 100644 index 000000000..e8de6d99e --- /dev/null +++ b/stdlib/source/library/lux/time/date.lux @@ -0,0 +1,349 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [enum (#+ Enum)] + [codec (#+ Codec)] + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser + ["<text>" text (#+ Parser)]]] + [data + ["." maybe] + ["." text ("#\." monoid)] + [collection + ["." list ("#\." fold)] + ["." dictionary (#+ Dictionary)]]] + [math + [number + ["n" nat ("#\." decimal)] + ["i" int]]] + [type + abstract]]] + ["." // #_ + ["#." year (#+ Year)] + ["#." month (#+ Month)]]) + +(def: month_by_number + (Dictionary Nat Month) + (list\fold (function (_ month mapping) + (dictionary.put (//month.number month) month mapping)) + (dictionary.new n.hash) + //month.year)) + +(def: minimum_day + 1) + +(def: (month_days year month) + (-> Year Month Nat) + (if (//year.leap? year) + (//month.leap_year_days month) + (//month.days month))) + +(def: (day_is_within_limits? year month day) + (-> Year Month Nat Bit) + (and (n.>= ..minimum_day day) + (n.<= (..month_days year month) day))) + +(exception: #export (invalid_day {year Year} {month Month} {day Nat}) + (exception.report + ["Value" (n\encode day)] + ["Minimum" (n\encode ..minimum_day)] + ["Maximum" (n\encode (..month_days year month))] + ["Year" (\ //year.codec encode year)] + ["Month" (n\encode (//month.number month))])) + +(def: (pad value) + (-> Nat Text) + (let [digits (n\encode value)] + (if (n.< 10 value) + (text\compose "0" digits) + digits))) + +(def: separator + "-") + +(abstract: #export Date + {#year Year + #month Month + #day Nat} + + (def: #export (date year month day) + (-> Year Month Nat (Try Date)) + (if (..day_is_within_limits? year month day) + (#try.Success + (:abstraction + {#year year + #month month + #day day})) + (exception.throw ..invalid_day [year month day]))) + + (def: #export epoch + Date + (try.assume (..date //year.epoch + #//month.January + ..minimum_day))) + + (template [<name> <type> <field>] + [(def: #export <name> + (-> Date <type>) + (|>> :representation (get@ <field>)))] + + [year Year #year] + [month Month #month] + [day_of_month Nat #day] + ) + + (implementation: #export equivalence + (Equivalence Date) + + (def: (= reference sample) + (let [reference (:representation reference) + sample (:representation sample)] + (and (\ //year.equivalence = + (get@ #year reference) + (get@ #year sample)) + (\ //month.equivalence = + (get@ #month reference) + (get@ #month sample)) + (n.= (get@ #day reference) + (get@ #day sample)))))) + + (implementation: #export order + (Order Date) + + (def: &equivalence ..equivalence) + + (def: (< reference sample) + (let [reference (:representation reference) + sample (:representation sample)] + (or (\ //year.order < + (get@ #year reference) + (get@ #year sample)) + (and (\ //year.equivalence = + (get@ #year reference) + (get@ #year sample)) + (or (\ //month.order < + (get@ #month reference) + (get@ #month sample)) + (and (\ //month.order = + (get@ #month reference) + (get@ #month sample)) + (n.< (get@ #day reference) + (get@ #day sample))))))))) + ) + +(def: parse_section + (Parser Nat) + (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))) + +(def: parse_millis + (Parser Nat) + (<>.either (|> (<text>.at_most 3 <text>.decimal) + (<>.codec n.decimal) + (<>.after (<text>.this "."))) + (\ <>.monad wrap 0))) + +(template [<minimum> <maximum> <parser> <exception>] + [(exception: #export (<exception> {value Nat}) + (exception.report + ["Value" (n\encode value)] + ["Minimum" (n\encode <minimum>)] + ["Maximum" (n\encode <maximum>)])) + + (def: <parser> + (Parser Nat) + (do <>.monad + [value ..parse_section] + (if (and (n.>= <minimum> value) + (n.<= <maximum> value)) + (wrap value) + (<>.lift (exception.throw <exception> [value])))))] + + [1 12 parse_month invalid_month] + ) + +(def: #export parser + (Parser Date) + (do <>.monad + [utc_year //year.parser + _ (<text>.this ..separator) + utc_month ..parse_month + _ (<text>.this ..separator) + #let [month (maybe.assume (dictionary.get utc_month ..month_by_number))] + utc_day ..parse_section] + (<>.lift (..date utc_year month utc_day)))) + +(def: (encode value) + (-> Date Text) + ($_ text\compose + (\ //year.codec encode (..year value)) + ..separator (..pad (|> value ..month //month.number)) + ..separator (..pad (..day_of_month value)))) + +(implementation: #export codec + {#.doc (doc "Based on ISO 8601." + "For example: 2017-01-15")} + (Codec Text Date) + + (def: encode ..encode) + (def: decode (<text>.run ..parser))) + +(def: days_per_leap + (|> //year.days + (n.* 4) + (n.+ 1))) + +(def: days_per_century + (let [leaps_per_century (n./ //year.leap + //year.century)] + (|> //year.century + (n.* //year.days) + (n.+ leaps_per_century) + (n.- 1)))) + +(def: days_per_era + (let [centuries_per_era (n./ //year.century + //year.era)] + (|> centuries_per_era + (n.* ..days_per_century) + (n.+ 1)))) + +(def: days_since_epoch + (let [years::70 70 + leaps::70 (n./ //year.leap + years::70) + days::70 (|> years::70 + (n.* //year.days) + (n.+ leaps::70)) + ## The epoch is being calculated from March 1st, instead of January 1st. + january_&_february (n.+ (//month.days #//month.January) + (//month.days #//month.February))] + (|> 0 + ## 1600/01/01 + (n.+ (n.* 4 days_per_era)) + ## 1900/01/01 + (n.+ (n.* 3 days_per_century)) + ## 1970/01/01 + (n.+ days::70) + ## 1970/03/01 + (n.- january_&_february)))) + +(def: first_month_of_civil_year 3) + +(with_expansions [<pull> +3 + <push> +9] + (def: (internal_month civil_month) + (-> Nat Int) + (if (n.< ..first_month_of_civil_year civil_month) + (i.+ <push> (.int civil_month)) + (i.- <pull> (.int civil_month)))) + + (def: (civil_month internal_month) + (-> Int Nat) + (.nat (if (i.< +10 internal_month) + (i.+ <pull> internal_month) + (i.- <push> internal_month))))) + +(with_expansions [<up> +153 + <translation> +2 + <down> +5] + (def: day_of_year_from_month + (-> Nat Int) + (|>> ..internal_month + (i.* <up>) + (i.+ <translation>) + (i./ <down>))) + + (def: month_from_day_of_year + (-> Int Nat) + (|>> (i.* <down>) + (i.+ <translation>) + (i./ <up>) + ..civil_month))) + +(def: last_era_leap_day + (.int (dec ..days_per_leap))) + +(def: last_era_day + (.int (dec ..days_per_era))) + +(def: (civil_year utc_month utc_year) + (-> Nat Year Int) + (let [## Coercing, because the year is already in external form. + utc_year (:as Int utc_year)] + (if (n.< ..first_month_of_civil_year utc_month) + (dec utc_year) + utc_year))) + +## http://howardhinnant.github.io/date_algorithms.html +(def: #export (to_days date) + (-> Date Int) + (let [utc_month (|> date ..month //month.number) + civil_year (..civil_year utc_month (..year date)) + era (|> (if (i.< +0 civil_year) + (i.- (.int (dec //year.era)) + civil_year) + civil_year) + (i./ (.int //year.era))) + year_of_era (i.- (i.* (.int //year.era) + era) + civil_year) + day_of_year (|> utc_month + ..day_of_year_from_month + (i.+ (.int (dec (..day_of_month date))))) + day_of_era (|> day_of_year + (i.+ (i.* (.int //year.days) year_of_era)) + (i.+ (i./ (.int //year.leap) year_of_era)) + (i.- (i./ (.int //year.century) year_of_era)))] + (|> (i.* (.int ..days_per_era) era) + (i.+ day_of_era) + (i.- (.int ..days_since_epoch))))) + +## http://howardhinnant.github.io/date_algorithms.html +(def: #export (from_days days) + (-> Int Date) + (let [days (i.+ (.int ..days_since_epoch) days) + era (|> (if (i.< +0 days) + (i.- ..last_era_day days) + days) + (i./ (.int ..days_per_era))) + day_of_era (i.- (i.* (.int ..days_per_era) era) days) + year_of_era (|> day_of_era + (i.- (i./ ..last_era_leap_day day_of_era)) + (i.+ (i./ (.int ..days_per_century) day_of_era)) + (i.- (i./ ..last_era_day day_of_era)) + (i./ (.int //year.days))) + year (i.+ (i.* (.int //year.era) era) + year_of_era) + day_of_year (|> day_of_era + (i.- (i.* (.int //year.days) year_of_era)) + (i.- (i./ (.int //year.leap) year_of_era)) + (i.+ (i./ (.int //year.century) year_of_era))) + month (..month_from_day_of_year day_of_year) + day (|> day_of_year + (i.- (..day_of_year_from_month month)) + (i.+ +1) + .nat) + year (if (n.< ..first_month_of_civil_year month) + (inc year) + year)] + ## Coercing, because the year is already in internal form. + (try.assume (..date (:as Year year) + (maybe.assume (dictionary.get month ..month_by_number)) + day)))) + +(implementation: #export enum + (Enum Date) + + (def: &order ..order) + + (def: succ + (|>> ..to_days inc ..from_days)) + + (def: pred + (|>> ..to_days dec ..from_days))) diff --git a/stdlib/source/library/lux/time/day.lux b/stdlib/source/library/lux/time/day.lux new file mode 100644 index 000000000..157dd6c1f --- /dev/null +++ b/stdlib/source/library/lux/time/day.lux @@ -0,0 +1,121 @@ +(.module: + [library + [lux (#- nat) + [abstract + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [enum (#+ Enum)] + [codec (#+ Codec)]] + [control + ["." try] + ["." exception (#+ exception:)]] + [data + ["." text]] + [macro + ["." template]] + [math + [number + ["n" nat]]]]]) + +(type: #export Day + #Sunday + #Monday + #Tuesday + #Wednesday + #Thursday + #Friday + #Saturday) + +(implementation: #export equivalence + (Equivalence Day) + + (def: (= reference sample) + (case [reference sample] + (^template [<tag>] + [[<tag> <tag>] + #1]) + ([#Sunday] + [#Monday] + [#Tuesday] + [#Wednesday] + [#Thursday] + [#Friday] + [#Saturday]) + + _ + #0))) + +(def: (nat day) + (-> Day Nat) + (case day + #Sunday 0 + #Monday 1 + #Tuesday 2 + #Wednesday 3 + #Thursday 4 + #Friday 5 + #Saturday 6)) + +(implementation: #export order + (Order Day) + + (def: &equivalence ..equivalence) + + (def: (< reference sample) + (n.< (..nat reference) (..nat sample)))) + +(implementation: #export enum + (Enum Day) + + (def: &order ..order) + + (def: (succ day) + (case day + #Sunday #Monday + #Monday #Tuesday + #Tuesday #Wednesday + #Wednesday #Thursday + #Thursday #Friday + #Friday #Saturday + #Saturday #Sunday)) + + (def: (pred day) + (case day + #Monday #Sunday + #Tuesday #Monday + #Wednesday #Tuesday + #Thursday #Wednesday + #Friday #Thursday + #Saturday #Friday + #Sunday #Saturday))) + +(exception: #export (not_a_day_of_the_week {value Text}) + (exception.report + ["Value" (text.format value)])) + +(implementation: #export codec + (Codec Text Day) + + (def: (encode value) + (case value + (^template [<tag>] + [<tag> (template.text [<tag>])]) + ([#..Monday] + [#..Tuesday] + [#..Wednesday] + [#..Thursday] + [#..Friday] + [#..Saturday] + [#..Sunday]))) + (def: (decode value) + (case value + (^template [<tag>] + [(^ (template.text [<tag>])) (#try.Success <tag>)]) + ([#..Monday] + [#..Tuesday] + [#..Wednesday] + [#..Thursday] + [#..Friday] + [#..Saturday] + [#..Sunday]) + _ (exception.throw ..not_a_day_of_the_week [value])))) diff --git a/stdlib/source/library/lux/time/duration.lux b/stdlib/source/library/lux/time/duration.lux new file mode 100644 index 000000000..1de5dab4f --- /dev/null +++ b/stdlib/source/library/lux/time/duration.lux @@ -0,0 +1,203 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [enum (#+ Enum)] + [codec (#+ Codec)] + [monoid (#+ Monoid)] + [monad (#+ do)]] + [control + ["." try] + ["<>" parser + ["<t>" text (#+ Parser)]]] + [data + ["." text ("#\." monoid)]] + [math + [number + ["i" int] + ["." nat ("#\." decimal)]]] + [type + abstract]]] + ["." // #_ + ["#." year]]) + +(abstract: #export Duration + Int + + {#.doc "Durations have a resolution of milli-seconds."} + + (def: #export from_millis + (-> Int Duration) + (|>> :abstraction)) + + (def: #export to_millis + (-> Duration Int) + (|>> :representation)) + + (template [<op> <name>] + [(def: #export (<name> param subject) + (-> Duration Duration Duration) + (:abstraction (<op> (:representation param) (:representation subject))))] + + [i.+ merge] + [i.% frame] + ) + + (template [<op> <name>] + [(def: #export (<name> scalar) + (-> Nat Duration Duration) + (|>> :representation (<op> (.int scalar)) :abstraction))] + + [i.* up] + [i./ down] + ) + + (def: #export inverse + (-> Duration Duration) + (|>> :representation (i.* -1) :abstraction)) + + (def: #export (query param subject) + (-> Duration Duration Int) + (i./ (:representation param) (:representation subject))) + + (implementation: #export equivalence + (Equivalence Duration) + + (def: (= param subject) + (i.= (:representation param) (:representation subject)))) + + (implementation: #export order + (Order Duration) + + (def: &equivalence ..equivalence) + (def: (< param subject) + (i.< (:representation param) (:representation subject)))) + + (template [<op> <name>] + [(def: #export <name> + (-> Duration Bit) + (|>> :representation (<op> +0)))] + + [i.> positive?] + [i.< negative?] + [i.= neutral?] + ) + ) + +(def: #export empty + (..from_millis +0)) + +(def: #export milli_second + (..from_millis +1)) + +(template [<name> <scale> <base>] + [(def: #export <name> + (..up <scale> <base>))] + + [second 1,000 milli_second] + [minute 60 second] + [hour 60 minute] + [day 24 hour] + + [week 7 day] + [normal_year //year.days day] + ) + +(def: #export leap_year + (..merge ..day ..normal_year)) + +(implementation: #export monoid + (Monoid Duration) + + (def: identity ..empty) + (def: compose ..merge)) + +(template [<value> <definition>] + [(def: <definition> <value>)] + + ["D" day_suffix] + ["h" hour_suffix] + ["m" minute_suffix] + ["s" second_suffix] + ["ms" milli_second_suffix] + + ["+" positive_sign] + ["-" negative_sign] + ) + +(def: (encode duration) + (if (\ ..equivalence = ..empty duration) + ($_ text\compose + ..positive_sign + (nat\encode 0) + ..milli_second_suffix) + (let [signed? (negative? duration) + [days time_left] [(query day duration) (frame day duration)] + days (if signed? + (i.abs days) + days) + time_left (if signed? + (..inverse time_left) + time_left) + [hours time_left] [(query hour time_left) (frame hour time_left)] + [minutes time_left] [(query minute time_left) (frame minute time_left)] + [seconds time_left] [(query second time_left) (frame second time_left)] + millis (to_millis time_left)] + ($_ text\compose + (if signed? ..negative_sign ..positive_sign) + (if (i.= +0 days) "" (text\compose (nat\encode (.nat days)) ..day_suffix)) + (if (i.= +0 hours) "" (text\compose (nat\encode (.nat hours)) ..hour_suffix)) + (if (i.= +0 minutes) "" (text\compose (nat\encode (.nat minutes)) ..minute_suffix)) + (if (i.= +0 seconds) "" (text\compose (nat\encode (.nat seconds)) ..second_suffix)) + (if (i.= +0 millis) "" (text\compose (nat\encode (.nat millis)) ..milli_second_suffix)) + )))) + +(def: parser + (Parser Duration) + (let [section (: (-> Text Text (Parser Nat)) + (function (_ suffix false_suffix) + (|> (<t>.many <t>.decimal) + (<>.codec nat.decimal) + (<>.before (case false_suffix + "" (<t>.this suffix) + _ (<>.after (<>.not (<t>.this false_suffix)) + (<t>.this suffix)))) + (<>.default 0))))] + (do <>.monad + [sign (<>.or (<t>.this ..negative_sign) + (<t>.this ..positive_sign)) + days (section ..day_suffix "") + hours (section hour_suffix "") + minutes (section ..minute_suffix ..milli_second_suffix) + seconds (section ..second_suffix "") + millis (section ..milli_second_suffix "") + #let [span (|> ..empty + (..merge (..up days ..day)) + (..merge (..up hours ..hour)) + (..merge (..up minutes ..minute)) + (..merge (..up seconds ..second)) + (..merge (..up millis ..milli_second)))]] + (wrap (case sign + (#.Left _) (..inverse span) + (#.Right _) span))))) + +(implementation: #export codec + (Codec Text Duration) + + (def: encode ..encode) + (def: decode (<t>.run ..parser))) + +(def: #export (difference from to) + (-> Duration Duration Duration) + (|> from ..inverse (..merge to))) + +(implementation: #export enum + (Enum Duration) + + (def: &order ..order) + (def: succ + (..merge ..milli_second)) + (def: pred + (..merge (..inverse ..milli_second)))) diff --git a/stdlib/source/library/lux/time/instant.lux b/stdlib/source/library/lux/time/instant.lux new file mode 100644 index 000000000..ecefe3491 --- /dev/null +++ b/stdlib/source/library/lux/time/instant.lux @@ -0,0 +1,235 @@ +(.module: + [library + [lux #* + ["@" target] + [abstract + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [enum (#+ Enum)] + [codec (#+ Codec)] + [monad (#+ Monad do)]] + [control + [io (#+ IO io)] + ["." try] + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" text (#+ Parser)]]] + [data + ["." maybe] + ["." text ("#\." monoid)] + [collection + ["." row]]] + [math + [number + ["i" int] + ["f" frac]]] + [type + abstract]]] + ["." // (#+ Time) + ["." duration (#+ Duration)] + ["." year (#+ Year)] + ["." month (#+ Month)] + ["." day (#+ Day)] + ["." date (#+ Date)]]) + +(abstract: #export Instant + Int + + {#.doc "Instant is defined as milliseconds since the epoch."} + + (def: #export from_millis + (-> Int Instant) + (|>> :abstraction)) + + (def: #export to_millis + (-> Instant Int) + (|>> :representation)) + + (def: #export (span from to) + (-> Instant Instant Duration) + (duration.from_millis (i.- (:representation from) (:representation to)))) + + (def: #export (shift duration instant) + (-> Duration Instant Instant) + (:abstraction (i.+ (duration.to_millis duration) (:representation instant)))) + + (def: #export (relative instant) + (-> Instant Duration) + (|> instant :representation duration.from_millis)) + + (def: #export (absolute offset) + (-> Duration Instant) + (|> offset duration.to_millis :abstraction)) + + (implementation: #export equivalence + (Equivalence Instant) + + (def: (= param subject) + (\ i.equivalence = (:representation param) (:representation subject)))) + + (implementation: #export order + (Order Instant) + + (def: &equivalence ..equivalence) + (def: (< param subject) + (\ i.order < (:representation param) (:representation subject)))) + + (`` (implementation: #export enum + (Enum Instant) + + (def: &order ..order) + (~~ (template [<name>] + [(def: <name> + (|>> :representation (\ i.enum <name>) :abstraction))] + + [succ] [pred] + )))) + ) + +(def: #export epoch + {#.doc "The instant corresponding to 1970-01-01T00:00:00Z"} + Instant + (..from_millis +0)) + +(def: millis_per_day + (duration.query duration.milli_second duration.day)) + +(def: (split_date_time instant) + (-> Instant [Date Duration]) + (let [offset (..to_millis instant) + bce? (i.< +0 offset) + [days day_time] (if bce? + (let [[days millis] (i./% ..millis_per_day offset)] + (case millis + +0 [days millis] + _ [(dec days) (i.+ ..millis_per_day millis)])) + (i./% ..millis_per_day offset))] + [(date.from_days days) + (duration.from_millis day_time)])) + +(template [<value> <definition>] + [(def: <definition> Text <value>)] + + ["T" date_suffix] + ["Z" time_suffix] + ) + +(def: (clock_time duration) + (-> Duration Time) + (let [time (if (\ duration.order < duration.empty duration) + (duration.merge duration.day duration) + duration)] + (|> time duration.to_millis .nat //.from_millis try.assume))) + +(def: (encode instant) + (-> Instant Text) + (let [[date time] (..split_date_time instant) + time (..clock_time time)] + ($_ text\compose + (\ date.codec encode date) ..date_suffix + (\ //.codec encode time) ..time_suffix))) + +(def: parser + (Parser Instant) + (do {! <>.monad} + [days (\ ! map date.to_days date.parser) + _ (<text>.this ..date_suffix) + time (\ ! map //.to_millis //.parser) + _ (<text>.this ..time_suffix)] + (wrap (|> (if (i.< +0 days) + (|> duration.day + (duration.up (.nat (i.* -1 days))) + duration.inverse) + (duration.up (.nat days) duration.day)) + (duration.merge (duration.up time duration.milli_second)) + ..absolute)))) + +(implementation: #export codec + {#.doc (doc "Based on ISO 8601." + "For example: 2017-01-15T21:14:51.827Z")} + (Codec Text Instant) + + (def: encode ..encode) + (def: decode (<text>.run ..parser))) + +(def: #export now + (IO Instant) + (io (..from_millis (for {@.old ("jvm invokestatic:java.lang.System:currentTimeMillis:") + @.jvm (|> ("jvm member invoke static" [] "java.lang.System" "currentTimeMillis" []) + ("jvm object cast") + (: (primitive "java.lang.Long")) + (:as Int)) + @.js (let [date ("js object new" ("js constant" "Date") [])] + (|> ("js object do" "getTime" date []) + (:as Frac) + "lux f64 i64")) + @.python (let [time ("python import" "time")] + (|> ("python object do" "time" time) + (:as Frac) + (f.* +1,000.0) + "lux f64 i64")) + @.lua (|> ("lua constant" "os.time") + "lua apply" + (:as Int) + (i.* +1,000)) + @.ruby (let [% ("ruby constant" "Time") + % ("ruby object do" "now" %)] + (|> ("ruby object do" "to_f" %) + (:as Frac) + (f.* +1,000.0) + "lux f64 i64")) + @.php (|> ("php constant" "time") + "php apply" + (:as Int) + (i.* +1,000)) + @.scheme (|> ("scheme constant" "current-second") + (:as Int) + (i.* +1,000) + ("scheme apply" ("scheme constant" "exact")) + ("scheme apply" ("scheme constant" "truncate"))) + @.common_lisp (|> ("common_lisp constant" "get-universal-time") + "common_lisp apply" + (:as Int) + (i.* +1,000)) + })))) + +(template [<field> <type> <post_processing>] + [(def: #export (<field> instant) + (-> Instant <type>) + (let [[date time] (..split_date_time instant)] + (|> <field> <post_processing>)))] + + [date Date (|>)] + [time Time ..clock_time] + ) + +(def: #export (day_of_week instant) + (-> Instant Day) + (let [offset (..relative instant) + days (duration.query duration.day offset) + day_time (duration.frame duration.day offset) + days (if (and (duration.negative? offset) + (not (duration.neutral? day_time))) + (dec days) + days) + ## 1970/01/01 was a Thursday + y1970m0d0 +4] + (case (|> y1970m0d0 + (i.+ days) (i.% +7) + ## This is done to turn negative days into positive days. + (i.+ +7) (i.% +7)) + +0 #day.Sunday + +1 #day.Monday + +2 #day.Tuesday + +3 #day.Wednesday + +4 #day.Thursday + +5 #day.Friday + +6 #day.Saturday + _ (undefined)))) + +(def: #export (from_date_time date time) + (-> Date Time Instant) + (|> (date.to_days date) + (i.* (duration.to_millis duration.day)) + (i.+ (.int (//.to_millis time))) + ..from_millis)) diff --git a/stdlib/source/library/lux/time/month.lux b/stdlib/source/library/lux/time/month.lux new file mode 100644 index 000000000..381094933 --- /dev/null +++ b/stdlib/source/library/lux/time/month.lux @@ -0,0 +1,225 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + [order (#+ Order)] + [enum (#+ Enum)] + [codec (#+ Codec)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." text]] + [macro + ["." template]] + [math + [number + ["n" nat]]]]]) + +(type: #export Month + #January + #February + #March + #April + #May + #June + #July + #August + #September + #October + #November + #December) + +(implementation: #export equivalence + (Equivalence Month) + + (def: (= reference sample) + (case [reference sample] + (^template [<tag>] + [[<tag> <tag>] + true]) + ([#January] + [#February] + [#March] + [#April] + [#May] + [#June] + [#July] + [#August] + [#September] + [#October] + [#November] + [#December]) + + _ + false))) + +(with_expansions [<pairs> (as_is [01 #January] + [02 #February] + [03 #March] + [04 #April] + [05 #May] + [06 #June] + [07 #July] + [08 #August] + [09 #September] + [10 #October] + [11 #November] + [12 #December])] + (def: #export (number month) + (-> Month Nat) + (case month + (^template [<number> <month>] + [<month> <number>]) + (<pairs>))) + + (exception: #export (invalid_month {number Nat}) + (exception.report + ["Number" (\ n.decimal encode number)] + ["Valid range" ($_ "lux text concat" + (\ n.decimal encode (..number #January)) + " ~ " + (\ n.decimal encode (..number #December)))])) + + (def: #export (by_number number) + (-> Nat (Try Month)) + (case number + (^template [<number> <month>] + [<number> (#try.Success <month>)]) + (<pairs>) + _ (exception.throw ..invalid_month [number]))) + ) + +(implementation: #export hash + (Hash Month) + + (def: &equivalence ..equivalence) + (def: hash ..number)) + +(implementation: #export order + (Order Month) + + (def: &equivalence ..equivalence) + + (def: (< reference sample) + (n.< (..number reference) (..number sample)))) + +(implementation: #export enum + (Enum Month) + + (def: &order ..order) + + (def: (succ month) + (case month + #January #February + #February #March + #March #April + #April #May + #May #June + #June #July + #July #August + #August #September + #September #October + #October #November + #November #December + #December #January)) + + (def: (pred month) + (case month + #February #January + #March #February + #April #March + #May #April + #June #May + #July #June + #August #July + #September #August + #October #September + #November #October + #December #November + #January #December))) + +(def: #export (days month) + (-> Month Nat) + (case month + (^template [<days> <month>] + [<month> <days>]) + ([31 #January] + [28 #February] + [31 #March] + + [30 #April] + [31 #May] + [30 #June] + + [31 #July] + [31 #August] + [30 #September] + + [31 #October] + [30 #November] + [31 #December]))) + +(def: #export (leap_year_days month) + (-> Month Nat) + (case month + #February (inc (..days month)) + _ (..days month))) + +(def: #export year + (List Month) + (list #January + #February + #March + #April + #May + #June + #July + #August + #September + #October + #November + #December)) + +(exception: #export (not_a_month_of_the_year {value Text}) + (exception.report + ["Value" (text.format value)])) + +(implementation: #export codec + (Codec Text Month) + + (def: (encode value) + (case value + (^template [<tag>] + [<tag> (template.text [<tag>])]) + ([#..January] + [#..February] + [#..March] + [#..April] + [#..May] + [#..June] + [#..July] + [#..August] + [#..September] + [#..October] + [#..November] + [#..December]))) + (def: (decode value) + (case value + (^template [<tag>] + [(^ (template.text [<tag>])) (#try.Success <tag>)]) + ([#..January] + [#..February] + [#..March] + [#..April] + [#..May] + [#..June] + [#..July] + [#..August] + [#..September] + [#..October] + [#..November] + [#..December]) + _ (exception.throw ..not_a_month_of_the_year [value])))) diff --git a/stdlib/source/library/lux/time/year.lux b/stdlib/source/library/lux/time/year.lux new file mode 100644 index 000000000..95280df9c --- /dev/null +++ b/stdlib/source/library/lux/time/year.lux @@ -0,0 +1,142 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)] + [codec (#+ Codec)] + [equivalence (#+ Equivalence)] + [order (#+ Order)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser + ["<t>" text (#+ Parser)]]] + [data + ["." text ("#\." monoid)]] + [math + [number + ["n" nat ("#\." decimal)] + ["i" int ("#\." decimal)]]] + [type + abstract]]]) + +(def: (internal year) + (-> Int Int) + (if (i.< +0 year) + (inc year) + year)) + +(def: (external year) + (-> Int Int) + (if (i.> +0 year) + year + (dec year))) + +(exception: #export there-is-no-year-0) + +(abstract: #export Year + Int + + (def: #export (year value) + (-> Int (Try Year)) + (case value + +0 (exception.throw ..there-is-no-year-0 []) + _ (#try.Success (:abstraction (..internal value))))) + + (def: #export value + (-> Year Int) + (|>> :representation ..external)) + + (def: #export epoch + Year + (:abstraction +1970)) + ) + +(def: #export days + 365) + +(type: #export Period + Nat) + +(template [<period> <name>] + [(def: #export <name> + Period + <period>)] + + [004 leap] + [100 century] + [400 era] + ) + +(def: (divisible? factor input) + (-> Int Int Bit) + (|> input (i.% factor) (i.= +0))) + +## https://en.wikipedia.org/wiki/Leap_year#Algorithm +(def: #export (leap? year) + (-> Year Bit) + (let [year (|> year ..value ..internal)] + (and (..divisible? (.int ..leap) year) + (or (not (..divisible? (.int ..century) year)) + (..divisible? (.int ..era) year))))) + +(def: (with-year-0-leap year days) + (let [after-year-0? (i.> +0 year)] + (if after-year-0? + (i.+ +1 days) + days))) + +(def: #export (leaps year) + (-> Year Int) + (let [year (|> year ..value ..internal) + limit (if (i.> +0 year) + (dec year) + (inc year))] + (`` (|> +0 + (~~ (template [<polarity> <years>] + [(<polarity> (i./ (.int <years>) limit))] + + [i.+ ..leap] + [i.- ..century] + [i.+ ..era] + )) + (..with-year-0-leap year))))) + +(def: (encode year) + (-> Year Text) + (let [year (..value year)] + (if (i.< +0 year) + (i\encode year) + (n\encode (.nat year))))) + +(def: #export parser + (Parser Year) + (do {! <>.monad} + [sign (<>.or (<t>.this "-") (wrap [])) + digits (<t>.many <t>.decimal) + raw-year (<>.codec i.decimal (wrap (text\compose "+" digits)))] + (<>.lift (..year (case sign + (#.Left _) (i.* -1 raw-year) + (#.Right _) raw-year))))) + +(implementation: #export codec + {#.doc (doc "Based on ISO 8601." + "For example: 2017")} + (Codec Text Year) + + (def: encode ..encode) + (def: decode (<t>.run ..parser))) + +(implementation: #export equivalence + (Equivalence Year) + + (def: (= reference subject) + (i.= (..value reference) (..value subject)))) + +(implementation: #export order + (Order Year) + + (def: &equivalence ..equivalence) + + (def: (< reference subject) + (i.< (..value reference) (..value subject)))) diff --git a/stdlib/source/library/lux/tool/compiler.lux b/stdlib/source/library/lux/tool/compiler.lux new file mode 100644 index 000000000..1acd9aeea --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler.lux @@ -0,0 +1,47 @@ +(.module: + [library + [lux (#- Module Code) + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + [binary (#+ Binary)] + ["." text] + [collection + ["." row (#+ Row)]]] + [world + ["." file (#+ Path)]]]] + [/ + [meta + ["." archive (#+ Output Archive) + [key (#+ Key)] + [descriptor (#+ Descriptor Module)] + [document (#+ Document)]]]]) + +(type: #export Code + Text) + +(type: #export Parameter + Text) + +(type: #export Input + {#module Module + #file Path + #hash Nat + #code Code}) + +(type: #export (Compilation s d o) + {#dependencies (List Module) + #process (-> s Archive + (Try [s (Either (Compilation s d o) + [Descriptor (Document d) Output])]))}) + +(type: #export (Compiler s d o) + (-> Input (Compilation s d o))) + +(type: #export (Instancer s d o) + (-> (Key d) (List Parameter) (Compiler s d o))) + +(exception: #export (cannot_compile {module Module}) + (exception.report + ["Module" module])) diff --git a/stdlib/source/library/lux/tool/compiler/arity.lux b/stdlib/source/library/lux/tool/compiler/arity.lux new file mode 100644 index 000000000..61e0ea625 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/arity.lux @@ -0,0 +1,16 @@ +(.module: + [library + [lux #* + [math + [number + ["n" nat]]]]]) + +(type: #export Arity Nat) + +(template [<comparison> <name>] + [(def: #export <name> (-> Arity Bit) (<comparison> 1))] + + [n.< nullary?] + [n.= unary?] + [n.> multiary?] + ) diff --git a/stdlib/source/library/lux/tool/compiler/default/init.lux b/stdlib/source/library/lux/tool/compiler/default/init.lux new file mode 100644 index 000000000..172de25e7 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/default/init.lux @@ -0,0 +1,287 @@ +(.module: + [library + [lux (#- Module) + ["@" target (#+ Target)] + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + [binary (#+ Binary)] + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)] + ["." dictionary] + ["." set] + ["." row ("#\." functor)]]] + ["." meta] + [world + ["." file]]]] + ["." // #_ + ["/#" // (#+ Instancer) + ["#." phase] + [language + [lux + [program (#+ Program)] + ["#." version] + ["#." syntax (#+ Aliases)] + ["#." synthesis] + ["#." directive (#+ Requirements)] + ["#." generation] + ["#." analysis + [macro (#+ Expander)] + ["#/." evaluation]] + [phase + [".P" synthesis] + [".P" directive] + [".P" analysis + ["." module]] + ["." extension (#+ Extender) + [".E" analysis] + [".E" synthesis] + [directive + [".D" lux]]]]]] + [meta + ["." archive (#+ Archive) + ["." descriptor (#+ Module)] + ["." artifact] + ["." document]]]]]) + +(def: #export (state target module expander host_analysis host generate generation_bundle) + (All [anchor expression directive] + (-> Target + Module + Expander + ///analysis.Bundle + (///generation.Host expression directive) + (///generation.Phase anchor expression directive) + (///generation.Bundle anchor expression directive) + (///directive.State+ anchor expression directive))) + (let [synthesis_state [synthesisE.bundle ///synthesis.init] + generation_state [generation_bundle (///generation.state host module)] + eval (///analysis/evaluation.evaluator expander synthesis_state generation_state generate) + analysis_state [(analysisE.bundle eval host_analysis) + (///analysis.state (///analysis.info ///version.version target))]] + [extension.empty + {#///directive.analysis {#///directive.state analysis_state + #///directive.phase (analysisP.phase expander)} + #///directive.synthesis {#///directive.state synthesis_state + #///directive.phase synthesisP.phase} + #///directive.generation {#///directive.state generation_state + #///directive.phase generate}}])) + +(def: #export (with_default_directives expander host_analysis program anchorT,expressionT,directiveT extender) + (All [anchor expression directive] + (-> Expander + ///analysis.Bundle + (Program expression directive) + [Type Type Type] + Extender + (-> (///directive.State+ anchor expression directive) + (///directive.State+ anchor expression directive)))) + (function (_ [directive_extensions sub_state]) + [(dictionary.merge directive_extensions + (luxD.bundle expander host_analysis program anchorT,expressionT,directiveT extender)) + sub_state])) + +(type: Reader + (-> Source (Either [Source Text] [Source Code]))) + +(def: (reader current_module aliases [location offset source_code]) + (-> Module Aliases Source (///analysis.Operation Reader)) + (function (_ [bundle state]) + (#try.Success [[bundle state] + (///syntax.parse current_module aliases ("lux text size" source_code))]))) + +(def: (read source reader) + (-> Source Reader (///analysis.Operation [Source Code])) + (function (_ [bundle compiler]) + (case (reader source) + (#.Left [source' error]) + (#try.Failure error) + + (#.Right [source' output]) + (let [[location _] output] + (#try.Success [[bundle (|> compiler + (set@ #.source source') + (set@ #.location location))] + [source' output]]))))) + +(type: (Operation a) + (All [anchor expression directive] + (///directive.Operation anchor expression directive a))) + +(type: (Payload directive) + [(///generation.Buffer directive) + artifact.Registry]) + +(def: (begin dependencies hash input) + (-> (List Module) Nat ///.Input + (All [anchor expression directive] + (///directive.Operation anchor expression directive + [Source (Payload directive)]))) + (do ///phase.monad + [#let [module (get@ #///.module input)] + _ (///directive.set_current_module module)] + (///directive.lift_analysis + (do {! ///phase.monad} + [_ (module.create hash module) + _ (monad.map ! module.import dependencies) + #let [source (///analysis.source (get@ #///.module input) (get@ #///.code input))] + _ (///analysis.set_source_code source)] + (wrap [source [///generation.empty_buffer + artifact.empty]]))))) + +(def: (end module) + (-> Module + (All [anchor expression directive] + (///directive.Operation anchor expression directive [.Module (Payload directive)]))) + (do ///phase.monad + [_ (///directive.lift_analysis + (module.set_compiled module)) + analysis_module (<| (: (Operation .Module)) + ///directive.lift_analysis + extension.lift + meta.current_module) + final_buffer (///directive.lift_generation + ///generation.buffer) + final_registry (///directive.lift_generation + ///generation.get_registry)] + (wrap [analysis_module [final_buffer + final_registry]]))) + +## TODO: Inline ASAP +(def: (get_current_payload _) + (All [directive] + (-> (Payload directive) + (All [anchor expression] + (///directive.Operation anchor expression directive + (Payload directive))))) + (do ///phase.monad + [buffer (///directive.lift_generation + ///generation.buffer) + registry (///directive.lift_generation + ///generation.get_registry)] + (wrap [buffer registry]))) + +## TODO: Inline ASAP +(def: (process_directive archive expander pre_payoad code) + (All [directive] + (-> Archive Expander (Payload directive) Code + (All [anchor expression] + (///directive.Operation anchor expression directive + [Requirements (Payload directive)])))) + (do ///phase.monad + [#let [[pre_buffer pre_registry] pre_payoad] + _ (///directive.lift_generation + (///generation.set_buffer pre_buffer)) + _ (///directive.lift_generation + (///generation.set_registry pre_registry)) + requirements (let [execute! (directiveP.phase expander)] + (execute! archive code)) + post_payload (..get_current_payload pre_payoad)] + (wrap [requirements post_payload]))) + +(def: (iteration archive expander reader source pre_payload) + (All [directive] + (-> Archive Expander Reader Source (Payload directive) + (All [anchor expression] + (///directive.Operation anchor expression directive + [Source Requirements (Payload directive)])))) + (do ///phase.monad + [[source code] (///directive.lift_analysis + (..read source reader)) + [requirements post_payload] (process_directive archive expander pre_payload code)] + (wrap [source requirements post_payload]))) + +(def: (iterate archive expander module source pre_payload aliases) + (All [directive] + (-> Archive Expander Module Source (Payload directive) Aliases + (All [anchor expression] + (///directive.Operation anchor expression directive + (Maybe [Source Requirements (Payload directive)]))))) + (do ///phase.monad + [reader (///directive.lift_analysis + (..reader module aliases source))] + (function (_ state) + (case (///phase.run' state (..iteration archive expander reader source pre_payload)) + (#try.Success [state source&requirements&buffer]) + (#try.Success [state (#.Some source&requirements&buffer)]) + + (#try.Failure error) + (if (exception.match? ///syntax.end_of_file error) + (#try.Success [state #.None]) + (exception.with ///.cannot_compile module (#try.Failure error))))))) + +(def: (default_dependencies prelude input) + (-> Module ///.Input (List Module)) + (list& archive.runtime_module + (if (text\= prelude (get@ #///.module input)) + (list) + (list prelude)))) + +(def: module_aliases + (-> .Module Aliases) + (|>> (get@ #.module_aliases) (dictionary.from_list text.hash))) + +(def: #export (compiler expander prelude write_directive) + (All [anchor expression directive] + (-> Expander Module (-> directive Binary) + (Instancer (///directive.State+ anchor expression directive) .Module))) + (let [execute! (directiveP.phase expander)] + (function (_ key parameters input) + (let [dependencies (default_dependencies prelude input)] + {#///.dependencies dependencies + #///.process (function (_ state archive) + (do {! try.monad} + [#let [hash (text\hash (get@ #///.code input))] + [state [source buffer]] (<| (///phase.run' state) + (..begin dependencies hash input)) + #let [module (get@ #///.module input)]] + (loop [iteration (<| (///phase.run' state) + (..iterate archive expander module source buffer ///syntax.no_aliases))] + (do ! + [[state ?source&requirements&temporary_payload] iteration] + (case ?source&requirements&temporary_payload + #.None + (do ! + [[state [analysis_module [final_buffer final_registry]]] (///phase.run' state (..end module)) + #let [descriptor {#descriptor.hash hash + #descriptor.name module + #descriptor.file (get@ #///.file input) + #descriptor.references (set.from_list text.hash dependencies) + #descriptor.state #.Compiled + #descriptor.registry final_registry}]] + (wrap [state + (#.Right [descriptor + (document.write key analysis_module) + (row\map (function (_ [artifact_id directive]) + [artifact_id (write_directive directive)]) + final_buffer)])])) + + (#.Some [source requirements temporary_payload]) + (let [[temporary_buffer temporary_registry] temporary_payload] + (wrap [state + (#.Left {#///.dependencies (|> requirements + (get@ #///directive.imports) + (list\map product.left)) + #///.process (function (_ state archive) + (recur (<| (///phase.run' state) + (do {! ///phase.monad} + [analysis_module (<| (: (Operation .Module)) + ///directive.lift_analysis + extension.lift + meta.current_module) + _ (///directive.lift_generation + (///generation.set_buffer temporary_buffer)) + _ (///directive.lift_generation + (///generation.set_registry temporary_registry)) + _ (|> requirements + (get@ #///directive.referrals) + (monad.map ! (execute! archive))) + temporary_payload (..get_current_payload temporary_payload)] + (..iterate archive expander module source temporary_payload (..module_aliases analysis_module))))))})])) + )))))})))) diff --git a/stdlib/source/library/lux/tool/compiler/default/platform.lux b/stdlib/source/library/lux/tool/compiler/default/platform.lux new file mode 100644 index 000000000..9ebf79b7b --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/default/platform.lux @@ -0,0 +1,602 @@ +(.module: + [library + [lux (#- Module) + [type (#+ :share)] + ["." debug] + ["@" target] + [abstract + ["." monad (#+ Monad do)]] + [control + ["." function] + ["." try (#+ Try) ("#\." functor)] + ["." exception (#+ exception:)] + [concurrency + ["." promise (#+ Promise Resolver) ("#\." monad)] + ["." stm (#+ Var STM)]]] + [data + ["." binary (#+ Binary)] + ["." bit] + ["." product] + ["." maybe] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." dictionary (#+ Dictionary)] + ["." row (#+ Row) ("#\." fold)] + ["." set (#+ Set)] + ["." list ("#\." monoid functor fold)]] + [format + ["_" binary (#+ Writer)]]] + [world + ["." file (#+ Path)]]]] + ["." // #_ + ["#." init] + ["/#" // + ["#." phase (#+ Phase)] + [language + [lux + [program (#+ Program)] + ["$" /] + ["#." version] + ["." syntax] + ["#." analysis + [macro (#+ Expander)]] + ["#." synthesis] + ["#." generation (#+ Buffer)] + ["#." directive] + [phase + ["." extension (#+ Extender)] + [analysis + ["." module]]]]] + [meta + ["." archive (#+ Output Archive) + ["." artifact (#+ Registry)] + ["." descriptor (#+ Descriptor Module)] + ["." document (#+ Document)]] + [io (#+ Context) + ["." context] + ["ioW" archive]]]]] + [program + [compositor + ["." cli (#+ Compilation Library)] + ["." static (#+ Static)] + ["." import (#+ Import)]]]) + +(with_expansions [<type_vars> (as_is anchor expression directive) + <Operation> (as_is ///generation.Operation <type_vars>)] + (type: #export Phase_Wrapper + (All [s i o] (-> (Phase s i o) Any))) + + (type: #export (Platform <type_vars>) + {#&file_system (file.System Promise) + #host (///generation.Host expression directive) + #phase (///generation.Phase <type_vars>) + #runtime (<Operation> [Registry Output]) + #phase_wrapper (-> Archive (<Operation> Phase_Wrapper)) + #write (-> directive Binary)}) + + ## TODO: Get rid of this + (type: (Action a) + (Promise (Try a))) + + ## TODO: Get rid of this + (def: monad + (:as (Monad Action) + (try.with promise.monad))) + + (with_expansions [<Platform> (as_is (Platform <type_vars>)) + <State+> (as_is (///directive.State+ <type_vars>)) + <Bundle> (as_is (///generation.Bundle <type_vars>))] + + (def: writer + (Writer [Descriptor (Document .Module)]) + (_.and descriptor.writer + (document.writer $.writer))) + + (def: (cache_module static platform module_id [descriptor document output]) + (All [<type_vars>] + (-> Static <Platform> archive.ID [Descriptor (Document Any) Output] + (Promise (Try Any)))) + (let [system (get@ #&file_system platform) + write_artifact! (: (-> [artifact.ID Binary] (Action Any)) + (function (_ [artifact_id content]) + (ioW.write system static module_id artifact_id content)))] + (do {! ..monad} + [_ (ioW.prepare system static module_id) + _ (for {@.python (|> output + row.to_list + (list.chunk 128) + (monad.map ! (monad.map ! write_artifact!)) + (: (Action (List (List Any)))))} + (|> output + row.to_list + (monad.map ..monad write_artifact!) + (: (Action (List Any))))) + document (\ promise.monad wrap + (document.check $.key document))] + (ioW.cache system static module_id + (_.run ..writer [descriptor document]))))) + + ## TODO: Inline ASAP + (def: initialize_buffer! + (All [<type_vars>] + (///generation.Operation <type_vars> Any)) + (///generation.set_buffer ///generation.empty_buffer)) + + ## TODO: Inline ASAP + (def: (compile_runtime! platform) + (All [<type_vars>] + (-> <Platform> (///generation.Operation <type_vars> [Registry Output]))) + (do ///phase.monad + [_ ..initialize_buffer!] + (get@ #runtime platform))) + + (def: (runtime_descriptor registry) + (-> Registry Descriptor) + {#descriptor.hash 0 + #descriptor.name archive.runtime_module + #descriptor.file "" + #descriptor.references (set.new text.hash) + #descriptor.state #.Compiled + #descriptor.registry registry}) + + (def: runtime_document + (Document .Module) + (document.write $.key (module.new 0))) + + (def: (process_runtime archive platform) + (All [<type_vars>] + (-> Archive <Platform> + (///directive.Operation <type_vars> + [Archive [Descriptor (Document .Module) Output]]))) + (do ///phase.monad + [[registry payload] (///directive.lift_generation + (..compile_runtime! platform)) + #let [[descriptor document] [(..runtime_descriptor registry) ..runtime_document]] + archive (///phase.lift (if (archive.reserved? archive archive.runtime_module) + (archive.add archive.runtime_module [descriptor document payload] archive) + (do try.monad + [[_ archive] (archive.reserve archive.runtime_module archive)] + (archive.add archive.runtime_module [descriptor document payload] archive))))] + (wrap [archive [descriptor document payload]]))) + + (def: (initialize_state extender + [analysers + synthesizers + generators + directives] + analysis_state + state) + (All [<type_vars>] + (-> Extender + [(Dictionary Text ///analysis.Handler) + (Dictionary Text ///synthesis.Handler) + (Dictionary Text (///generation.Handler <type_vars>)) + (Dictionary Text (///directive.Handler <type_vars>))] + .Lux + <State+> + (Try <State+>))) + (|> (:share [<type_vars>] + <State+> + state + + (///directive.Operation <type_vars> Any) + (do ///phase.monad + [_ (///directive.lift_analysis + (///analysis.install analysis_state)) + _ (///directive.lift_analysis + (extension.with extender analysers)) + _ (///directive.lift_synthesis + (extension.with extender synthesizers)) + _ (///directive.lift_generation + (extension.with extender (:assume generators))) + _ (extension.with extender (:assume directives))] + (wrap []))) + (///phase.run' state) + (\ try.monad map product.left))) + + (def: (phase_wrapper archive platform state) + (All [<type_vars>] + (-> Archive <Platform> <State+> (Try [<State+> Phase_Wrapper]))) + (let [phase_wrapper (get@ #phase_wrapper platform)] + (|> archive + phase_wrapper + ///directive.lift_generation + (///phase.run' state)))) + + (def: (complete_extensions host_directive_bundle phase_wrapper [analysers synthesizers generators directives]) + (All [<type_vars>] + (-> (-> Phase_Wrapper (///directive.Bundle <type_vars>)) + Phase_Wrapper + [(Dictionary Text ///analysis.Handler) + (Dictionary Text ///synthesis.Handler) + (Dictionary Text (///generation.Handler <type_vars>)) + (Dictionary Text (///directive.Handler <type_vars>))] + [(Dictionary Text ///analysis.Handler) + (Dictionary Text ///synthesis.Handler) + (Dictionary Text (///generation.Handler <type_vars>)) + (Dictionary Text (///directive.Handler <type_vars>))])) + [analysers + synthesizers + generators + (dictionary.merge directives (host_directive_bundle phase_wrapper))]) + + (def: #export (initialize static module expander host_analysis platform generation_bundle host_directive_bundle program anchorT,expressionT,directiveT extender + import compilation_sources) + (All [<type_vars>] + (-> Static + Module + Expander + ///analysis.Bundle + <Platform> + <Bundle> + (-> Phase_Wrapper (///directive.Bundle <type_vars>)) + (Program expression directive) + [Type Type Type] (-> Phase_Wrapper Extender) + Import (List Context) + (Promise (Try [<State+> Archive])))) + (do {! (try.with promise.monad)} + [#let [state (//init.state (get@ #static.host static) + module + expander + host_analysis + (get@ #host platform) + (get@ #phase platform) + generation_bundle)] + _ (ioW.enable (get@ #&file_system platform) static) + [archive analysis_state bundles] (ioW.thaw (get@ #host platform) (get@ #&file_system platform) static import compilation_sources) + #let [with_missing_extensions + (: (All [<type_vars>] + (-> <Platform> (Program expression directive) <State+> (Promise (Try <State+>)))) + (function (_ platform program state) + (promise\wrap + (do try.monad + [[state phase_wrapper] (..phase_wrapper archive platform state)] + (|> state + (initialize_state (extender phase_wrapper) + (:assume (..complete_extensions host_directive_bundle phase_wrapper (:assume bundles))) + analysis_state) + (try\map (//init.with_default_directives expander host_analysis program anchorT,expressionT,directiveT (extender phase_wrapper))))))))]] + (if (archive.archived? archive archive.runtime_module) + (do ! + [state (with_missing_extensions platform program state)] + (wrap [state archive])) + (do ! + [[state [archive payload]] (|> (..process_runtime archive platform) + (///phase.run' state) + promise\wrap) + _ (..cache_module static platform 0 payload) + + state (with_missing_extensions platform program state)] + (wrap [state archive]))))) + + (def: compilation_log_separator + (format text.new_line text.tab)) + + (def: (module_compilation_log module) + (All [<type_vars>] + (-> Module <State+> Text)) + (|>> (get@ [#extension.state + #///directive.generation + #///directive.state + #extension.state + #///generation.log]) + (row\fold (function (_ right left) + (format left ..compilation_log_separator right)) + module))) + + (def: with_reset_log + (All [<type_vars>] + (-> <State+> <State+>)) + (set@ [#extension.state + #///directive.generation + #///directive.state + #extension.state + #///generation.log] + row.empty)) + + (def: empty + (Set Module) + (set.new text.hash)) + + (type: Mapping + (Dictionary Module (Set Module))) + + (type: Dependence + {#depends_on Mapping + #depended_by Mapping}) + + (def: independence + Dependence + (let [empty (dictionary.new text.hash)] + {#depends_on empty + #depended_by empty})) + + (def: (depend module import dependence) + (-> Module Module Dependence Dependence) + (let [transitive_dependency (: (-> (-> Dependence Mapping) Module (Set Module)) + (function (_ lens module) + (|> dependence + lens + (dictionary.get module) + (maybe.default ..empty)))) + transitive_depends_on (transitive_dependency (get@ #depends_on) import) + transitive_depended_by (transitive_dependency (get@ #depended_by) module) + update_dependence (: (-> [Module (Set Module)] [Module (Set Module)] + (-> Mapping Mapping)) + (function (_ [source forward] [target backward]) + (function (_ mapping) + (let [with_dependence+transitives + (|> mapping + (dictionary.upsert source ..empty (set.add target)) + (dictionary.update source (set.union forward)))] + (list\fold (function (_ previous) + (dictionary.upsert previous ..empty (set.add target))) + with_dependence+transitives + (set.to_list backward))))))] + (|> dependence + (update@ #depends_on + (update_dependence + [module transitive_depends_on] + [import transitive_depended_by])) + (update@ #depended_by + ((function.flip update_dependence) + [module transitive_depends_on] + [import transitive_depended_by]))))) + + (def: (circular_dependency? module import dependence) + (-> Module Module Dependence Bit) + (let [dependence? (: (-> Module (-> Dependence Mapping) Module Bit) + (function (_ from relationship to) + (let [targets (|> dependence + relationship + (dictionary.get from) + (maybe.default ..empty))] + (set.member? targets to))))] + (or (dependence? import (get@ #depends_on) module) + (dependence? module (get@ #depended_by) import)))) + + (exception: #export (module_cannot_import_itself {module Module}) + (exception.report + ["Module" (%.text module)])) + + (exception: #export (cannot_import_circular_dependency {importer Module} + {importee Module}) + (exception.report + ["Importer" (%.text importer)] + ["importee" (%.text importee)])) + + (def: (verify_dependencies importer importee dependence) + (-> Module Module Dependence (Try Any)) + (cond (text\= importer importee) + (exception.throw ..module_cannot_import_itself [importer]) + + (..circular_dependency? importer importee dependence) + (exception.throw ..cannot_import_circular_dependency [importer importee]) + + ## else + (#try.Success []))) + + (with_expansions [<Context> (as_is [Archive <State+>]) + <Result> (as_is (Try <Context>)) + <Return> (as_is (Promise <Result>)) + <Signal> (as_is (Resolver <Result>)) + <Pending> (as_is [<Return> <Signal>]) + <Importer> (as_is (-> Module Module <Return>)) + <Compiler> (as_is (-> Module <Importer> archive.ID <Context> Module <Return>))] + (def: (parallel initial) + (All [<type_vars>] + (-> <Context> + (-> <Compiler> <Importer>))) + (let [current (stm.var initial) + pending (:share [<type_vars>] + <Context> + initial + + (Var (Dictionary Module <Pending>)) + (:assume (stm.var (dictionary.new text.hash)))) + dependence (: (Var Dependence) + (stm.var ..independence))] + (function (_ compile) + (function (import! importer module) + (do {! promise.monad} + [[return signal] (:share [<type_vars>] + <Context> + initial + + (Promise [<Return> (Maybe [<Context> + archive.ID + <Signal>])]) + (:assume + (stm.commit + (do {! stm.monad} + [dependence (if (text\= archive.runtime_module importer) + (stm.read dependence) + (do ! + [[_ dependence] (stm.update (..depend importer module) dependence)] + (wrap dependence)))] + (case (..verify_dependencies importer module dependence) + (#try.Failure error) + (wrap [(promise.resolved (#try.Failure error)) + #.None]) + + (#try.Success _) + (do ! + [[archive state] (stm.read current)] + (if (archive.archived? archive module) + (wrap [(promise\wrap (#try.Success [archive state])) + #.None]) + (do ! + [@pending (stm.read pending)] + (case (dictionary.get module @pending) + (#.Some [return signal]) + (wrap [return + #.None]) + + #.None + (case (if (archive.reserved? archive module) + (do try.monad + [module_id (archive.id module archive)] + (wrap [module_id archive])) + (archive.reserve module archive)) + (#try.Success [module_id archive]) + (do ! + [_ (stm.write [archive state] current) + #let [[return signal] (:share [<type_vars>] + <Context> + initial + + <Pending> + (promise.promise []))] + _ (stm.update (dictionary.put module [return signal]) pending)] + (wrap [return + (#.Some [[archive state] + module_id + signal])])) + + (#try.Failure error) + (wrap [(promise\wrap (#try.Failure error)) + #.None]))))))))))) + _ (case signal + #.None + (wrap []) + + (#.Some [context module_id resolver]) + (do ! + [result (compile importer import! module_id context module) + result (case result + (#try.Failure error) + (wrap result) + + (#try.Success [resulting_archive resulting_state]) + (stm.commit (do stm.monad + [[_ [merged_archive _]] (stm.update (function (_ [archive state]) + [(archive.merge resulting_archive archive) + state]) + current)] + (wrap (#try.Success [merged_archive resulting_state]))))) + _ (promise.future (resolver result))] + (wrap [])))] + return))))) + + ## TODO: Find a better way, as this only works for the Lux compiler. + (def: (updated_state archive state) + (All [<type_vars>] + (-> Archive <State+> (Try <State+>))) + (do {! try.monad} + [modules (monad.map ! (function (_ module) + (do ! + [[descriptor document output] (archive.find module archive) + lux_module (document.read $.key document)] + (wrap [module lux_module]))) + (archive.archived archive)) + #let [additions (|> modules + (list\map product.left) + (set.from_list text.hash))]] + (wrap (update@ [#extension.state + #///directive.analysis + #///directive.state + #extension.state] + (function (_ analysis_state) + (|> analysis_state + (:as .Lux) + (update@ #.modules (function (_ current) + (list\compose (list.filter (|>> product.left + (set.member? additions) + not) + current) + modules))) + :assume)) + state)))) + + (def: (set_current_module module state) + (All [<type_vars>] + (-> Module <State+> <State+>)) + (|> (///directive.set_current_module module) + (///phase.run' state) + try.assume + product.left)) + + (def: #export (compile import static expander platform compilation context) + (All [<type_vars>] + (-> Import Static Expander <Platform> Compilation <Context> <Return>)) + (let [[compilation_sources compilation_libraries compilation_target compilation_module] compilation + base_compiler (:share [<type_vars>] + <Context> + context + + (///.Compiler <State+> .Module Any) + (:assume + ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))) + compiler (..parallel + context + (function (_ importer import! module_id [archive state] module) + (do {! (try.with promise.monad)} + [#let [state (..set_current_module module state)] + input (context.read (get@ #&file_system platform) + importer + import + compilation_sources + (get@ #static.host_module_extension static) + module)] + (loop [[archive state] [archive state] + compilation (base_compiler (:as ///.Input input)) + all_dependencies (: (List Module) + (list))] + (let [new_dependencies (get@ #///.dependencies compilation) + all_dependencies (list\compose new_dependencies all_dependencies) + continue! (:share [<type_vars>] + <Platform> + platform + + (-> <Context> (///.Compilation <State+> .Module Any) (List Module) + (Action [Archive <State+>])) + (:assume + recur))] + (do ! + [[archive state] (case new_dependencies + #.Nil + (wrap [archive state]) + + (#.Cons _) + (do ! + [archive,document+ (|> new_dependencies + (list\map (import! module)) + (monad.seq ..monad)) + #let [archive (|> archive,document+ + (list\map product.left) + (list\fold archive.merge archive))]] + (wrap [archive (try.assume + (..updated_state archive state))])))] + (case ((get@ #///.process compilation) + ## TODO: The "///directive.set_current_module" below shouldn't be necessary. Remove it ASAP. + ## TODO: The context shouldn't need to be re-set either. + (|> (///directive.set_current_module module) + (///phase.run' state) + try.assume + product.left) + archive) + (#try.Success [state more|done]) + (case more|done + (#.Left more) + (continue! [archive state] more all_dependencies) + + (#.Right [descriptor document output]) + (do ! + [#let [_ (debug.log! (..module_compilation_log module state)) + descriptor (set@ #descriptor.references (set.from_list text.hash all_dependencies) descriptor)] + _ (..cache_module static platform module_id [descriptor document output])] + (case (archive.add module [descriptor document output] archive) + (#try.Success archive) + (wrap [archive + (..with_reset_log state)]) + + (#try.Failure error) + (promise\wrap (#try.Failure error))))) + + (#try.Failure error) + (do ! + [_ (ioW.freeze (get@ #&file_system platform) static archive)] + (promise\wrap (#try.Failure error))))))))))] + (compiler archive.runtime_module compilation_module))) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux.lux new file mode 100644 index 000000000..e6d5816a4 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux.lux @@ -0,0 +1,107 @@ +(.module: + [library + [lux #* + [control + ["<>" parser + ["<b>" binary (#+ Parser)]]] + [data + [format + ["_" binary (#+ Writer)]]]]] + ["." / #_ + ["#." version] + [phase + [analysis + ["." module]]] + [/// + [meta + [archive + ["." signature] + ["." key (#+ Key)]]]]]) + +## TODO: Remove #module_hash, #imports & #module_state ASAP. +## TODO: Not just from this parser, but from the lux.Module type. +(def: #export writer + (Writer .Module) + (let [definition (: (Writer Definition) + ($_ _.and _.bit _.type _.code _.any)) + name (: (Writer Name) + (_.and _.text _.text)) + alias (: (Writer Alias) + (_.and _.text _.text)) + global (: (Writer Global) + (_.or alias + definition)) + tag (: (Writer [Nat (List Name) Bit Type]) + ($_ _.and + _.nat + (_.list name) + _.bit + _.type)) + type (: (Writer [(List Name) Bit Type]) + ($_ _.and + (_.list name) + _.bit + _.type))] + ($_ _.and + ## #module_hash + _.nat + ## #module_aliases + (_.list alias) + ## #definitions + (_.list (_.and _.text global)) + ## #imports + (_.list _.text) + ## #tags + (_.list (_.and _.text tag)) + ## #types + (_.list (_.and _.text type)) + ## #module_annotations + (_.maybe _.code) + ## #module_state + _.any))) + +(def: #export parser + (Parser .Module) + (let [definition (: (Parser Definition) + ($_ <>.and <b>.bit <b>.type <b>.code <b>.any)) + name (: (Parser Name) + (<>.and <b>.text <b>.text)) + alias (: (Parser Alias) + (<>.and <b>.text <b>.text)) + global (: (Parser Global) + (<b>.or alias + definition)) + tag (: (Parser [Nat (List Name) Bit Type]) + ($_ <>.and + <b>.nat + (<b>.list name) + <b>.bit + <b>.type)) + type (: (Parser [(List Name) Bit Type]) + ($_ <>.and + (<b>.list name) + <b>.bit + <b>.type))] + ($_ <>.and + ## #module_hash + <b>.nat + ## #module_aliases + (<b>.list alias) + ## #definitions + (<b>.list (<>.and <b>.text global)) + ## #imports + (<b>.list <b>.text) + ## #tags + (<b>.list (<>.and <b>.text tag)) + ## #types + (<b>.list (<>.and <b>.text type)) + ## #module_annotations + (<b>.maybe <b>.code) + ## #module_state + (\ <>.monad wrap #.Cached)))) + +(def: #export key + (Key .Module) + (key.key {#signature.name (name_of ..compiler) + #signature.version /version.version} + (module.new 0))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis.lux new file mode 100644 index 000000000..c29eaaf54 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis.lux @@ -0,0 +1,556 @@ +(.module: + [library + [lux (#- nat int rev) + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + [monad (#+ do)]] + [control + ["." function] + ["." try] + ["." exception (#+ Exception)]] + [data + ["." product] + ["." maybe] + ["." bit ("#\." equivalence)] + ["." text ("#\." equivalence) + ["%" format (#+ Format format)]] + [collection + ["." list ("#\." functor fold)]]] + [math + [number + ["n" nat] + ["i" int] + ["r" rev] + ["f" frac]]] + [meta + ["." location]]]] + [// + [phase + ["." extension (#+ Extension)]] + [/// + [arity (#+ Arity)] + [version (#+ Version)] + ["." phase] + ["." reference (#+ Reference) + ["." variable (#+ Register Variable)]]]]) + +(type: #export #rec Primitive + #Unit + (#Bit Bit) + (#Nat Nat) + (#Int Int) + (#Rev Rev) + (#Frac Frac) + (#Text Text)) + +(type: #export Tag + Nat) + +(type: #export (Variant a) + {#lefts Nat + #right? Bit + #value a}) + +(def: #export (tag lefts right?) + (-> Nat Bit Nat) + (if right? + (inc lefts) + lefts)) + +(def: (lefts tag right?) + (-> Nat Bit Nat) + (if right? + (dec tag) + tag)) + +(def: #export (choice options pick) + (-> Nat Nat [Nat Bit]) + (let [right? (n.= (dec options) pick)] + [(..lefts pick right?) + right?])) + +(type: #export (Tuple a) + (List a)) + +(type: #export (Composite a) + (#Variant (Variant a)) + (#Tuple (Tuple a))) + +(type: #export #rec Pattern + (#Simple Primitive) + (#Complex (Composite Pattern)) + (#Bind Register)) + +(type: #export (Branch' e) + {#when Pattern + #then e}) + +(type: #export (Match' e) + [(Branch' e) (List (Branch' e))]) + +(type: #export (Environment a) + (List a)) + +(type: #export #rec Analysis + (#Primitive Primitive) + (#Structure (Composite Analysis)) + (#Reference Reference) + (#Case Analysis (Match' Analysis)) + (#Function (Environment Analysis) Analysis) + (#Apply Analysis Analysis) + (#Extension (Extension Analysis))) + +(type: #export Branch + (Branch' Analysis)) + +(type: #export Match + (Match' Analysis)) + +(implementation: primitive_equivalence + (Equivalence Primitive) + + (def: (= reference sample) + (case [reference sample] + [#Unit #Unit] + true + + (^template [<tag> <=>] + [[(<tag> reference) (<tag> sample)] + (<=> reference sample)]) + ([#Bit bit\=] + [#Nat n.=] + [#Int i.=] + [#Rev r.=] + [#Frac f.=] + [#Text text\=]) + + _ + false))) + +(implementation: #export (composite_equivalence (^open "/\.")) + (All [a] (-> (Equivalence a) (Equivalence (Composite a)))) + + (def: (= reference sample) + (case [reference sample] + [(#Variant [reference_lefts reference_right? reference_value]) + (#Variant [sample_lefts sample_right? sample_value])] + (and (n.= reference_lefts sample_lefts) + (bit\= reference_right? sample_right?) + (/\= reference_value sample_value)) + + [(#Tuple reference) (#Tuple sample)] + (\ (list.equivalence /\=) = reference sample) + + _ + false))) + +(implementation: #export (composite_hash super) + (All [a] (-> (Hash a) (Hash (Composite a)))) + + (def: &equivalence + (..composite_equivalence (\ super &equivalence))) + + (def: (hash value) + (case value + (#Variant [lefts right? value]) + ($_ n.* 2 + (\ n.hash hash lefts) + (\ bit.hash hash right?) + (\ super hash value)) + + (#Tuple members) + ($_ n.* 3 + (\ (list.hash super) hash members)) + ))) + +(implementation: pattern_equivalence + (Equivalence Pattern) + + (def: (= reference sample) + (case [reference sample] + [(#Simple reference) (#Simple sample)] + (\ primitive_equivalence = reference sample) + + [(#Complex reference) (#Complex sample)] + (\ (composite_equivalence =) = reference sample) + + [(#Bind reference) (#Bind sample)] + (n.= reference sample) + + _ + false))) + +(implementation: (branch_equivalence equivalence) + (-> (Equivalence Analysis) (Equivalence Branch)) + + (def: (= [reference_pattern reference_body] [sample_pattern sample_body]) + (and (\ pattern_equivalence = reference_pattern sample_pattern) + (\ equivalence = reference_body sample_body)))) + +(implementation: #export equivalence + (Equivalence Analysis) + + (def: (= reference sample) + (case [reference sample] + [(#Primitive reference) (#Primitive sample)] + (\ primitive_equivalence = reference sample) + + [(#Structure reference) (#Structure sample)] + (\ (composite_equivalence =) = reference sample) + + [(#Reference reference) (#Reference sample)] + (\ reference.equivalence = reference sample) + + [(#Case [reference_analysis reference_match]) + (#Case [sample_analysis sample_match])] + (and (= reference_analysis sample_analysis) + (\ (list.equivalence (branch_equivalence =)) = (#.Cons reference_match) (#.Cons sample_match))) + + [(#Function [reference_environment reference_analysis]) + (#Function [sample_environment sample_analysis])] + (and (= reference_analysis sample_analysis) + (\ (list.equivalence =) = reference_environment sample_environment)) + + [(#Apply [reference_input reference_abstraction]) + (#Apply [sample_input sample_abstraction])] + (and (= reference_input sample_input) + (= reference_abstraction sample_abstraction)) + + [(#Extension reference) (#Extension sample)] + (\ (extension.equivalence =) = reference sample) + + _ + false))) + +(template [<name> <tag>] + [(template: #export (<name> content) + (<tag> content))] + + [control/case #..Case] + ) + +(template: #export (unit) + (#..Primitive #..Unit)) + +(template [<name> <tag>] + [(template: #export (<name> value) + (#..Primitive (<tag> value)))] + + [bit #..Bit] + [nat #..Nat] + [int #..Int] + [rev #..Rev] + [frac #..Frac] + [text #..Text] + ) + +(type: #export (Abstraction c) + [(Environment c) Arity c]) + +(type: #export (Application c) + [c (List c)]) + +(def: (last? size tag) + (-> Nat Tag Bit) + (n.= (dec size) tag)) + +(template: #export (no_op value) + (|> 1 #variable.Local #reference.Variable #..Reference + (#..Function (list)) + (#..Apply value))) + +(def: #export (apply [abstraction inputs]) + (-> (Application Analysis) Analysis) + (list\fold (function (_ input abstraction') + (#Apply input abstraction')) + abstraction + inputs)) + +(def: #export (application analysis) + (-> Analysis (Application Analysis)) + (loop [abstraction analysis + inputs (list)] + (case abstraction + (#Apply input next) + (recur next (#.Cons input inputs)) + + _ + [abstraction inputs]))) + +(template [<name> <tag>] + [(template: #export (<name> content) + (.<| #..Reference + <tag> + content))] + + [variable #reference.Variable] + [constant #reference.Constant] + + [variable/local reference.local] + [variable/foreign reference.foreign] + ) + +(template [<name> <tag>] + [(template: #export (<name> content) + (.<| #..Complex + <tag> + content))] + + [pattern/variant #..Variant] + [pattern/tuple #..Tuple] + ) + +(template [<name> <tag>] + [(template: #export (<name> content) + (.<| #..Structure + <tag> + content))] + + [variant #..Variant] + [tuple #..Tuple] + ) + +(template: #export (pattern/unit) + (#..Simple #..Unit)) + +(template [<name> <tag>] + [(template: #export (<name> content) + (#..Simple (<tag> content)))] + + [pattern/bit #..Bit] + [pattern/nat #..Nat] + [pattern/int #..Int] + [pattern/rev #..Rev] + [pattern/frac #..Frac] + [pattern/text #..Text] + ) + +(template: #export (pattern/bind register) + (#..Bind register)) + +(def: #export (%analysis analysis) + (Format Analysis) + (case analysis + (#Primitive primitive) + (case primitive + #Unit + "[]" + + (^template [<tag> <format>] + [(<tag> value) + (<format> value)]) + ([#Bit %.bit] + [#Nat %.nat] + [#Int %.int] + [#Rev %.rev] + [#Frac %.frac] + [#Text %.text])) + + (#Structure structure) + (case structure + (#Variant [lefts right? value]) + (format "(" (%.nat lefts) " " (%.bit right?) " " (%analysis value) ")") + + (#Tuple members) + (|> members + (list\map %analysis) + (text.join_with " ") + (text.enclose ["[" "]"]))) + + (#Reference reference) + (reference.format reference) + + (#Case analysis match) + "{?}" + + (#Function environment body) + (|> (%analysis body) + (format " ") + (format (|> environment + (list\map %analysis) + (text.join_with " ") + (text.enclose ["[" "]"]))) + (text.enclose ["(" ")"])) + + (#Apply _) + (|> analysis + ..application + #.Cons + (list\map %analysis) + (text.join_with " ") + (text.enclose ["(" ")"])) + + (#Extension name parameters) + (|> parameters + (list\map %analysis) + (text.join_with " ") + (format (%.text name) " ") + (text.enclose ["(" ")"])))) + +(template [<special> <general>] + [(type: #export <special> + (<general> .Lux Code Analysis))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(def: #export (with_source_code source action) + (All [a] (-> Source (Operation a) (Operation a))) + (function (_ [bundle state]) + (let [old_source (get@ #.source state)] + (case (action [bundle (set@ #.source source state)]) + (#try.Success [[bundle' state'] output]) + (#try.Success [[bundle' (set@ #.source old_source state')] + output]) + + (#try.Failure error) + (#try.Failure error))))) + +(def: fresh_bindings + (All [k v] (Bindings k v)) + {#.counter 0 + #.mappings (list)}) + +(def: fresh_scope + Scope + {#.name (list) + #.inner 0 + #.locals fresh_bindings + #.captured fresh_bindings}) + +(def: #export (with_scope action) + (All [a] (-> (Operation a) (Operation [Scope a]))) + (function (_ [bundle state]) + (case (action [bundle (update@ #.scopes (|>> (#.Cons fresh_scope)) state)]) + (#try.Success [[bundle' state'] output]) + (case (get@ #.scopes state') + (#.Cons head tail) + (#try.Success [[bundle' (set@ #.scopes tail state')] + [head output]]) + + #.Nil + (#try.Failure "Impossible error: Drained scopes!")) + + (#try.Failure error) + (#try.Failure error)))) + +(def: #export (with_current_module name) + (All [a] (-> Text (Operation a) (Operation a))) + (extension.localized (get@ #.current_module) + (set@ #.current_module) + (function.constant (#.Some name)))) + +(def: #export (with_location location action) + (All [a] (-> Location (Operation a) (Operation a))) + (if (text\= "" (product.left location)) + action + (function (_ [bundle state]) + (let [old_location (get@ #.location state)] + (case (action [bundle (set@ #.location location state)]) + (#try.Success [[bundle' state'] output]) + (#try.Success [[bundle' (set@ #.location old_location state')] + output]) + + (#try.Failure error) + (#try.Failure error)))))) + +(def: (locate_error location error) + (-> Location Text Text) + (format (%.location location) text.new_line + error)) + +(def: #export (fail error) + (-> Text Operation) + (function (_ [bundle state]) + (#try.Failure (locate_error (get@ #.location state) error)))) + +(def: #export (throw exception parameters) + (All [e] (-> (Exception e) e Operation)) + (..fail (exception.construct exception parameters))) + +(def: #export (assert exception parameters condition) + (All [e] (-> (Exception e) e Bit (Operation Any))) + (if condition + (\ phase.monad wrap []) + (..throw exception parameters))) + +(def: #export (fail' error) + (-> Text (phase.Operation Lux)) + (function (_ state) + (#try.Failure (locate_error (get@ #.location state) error)))) + +(def: #export (throw' exception parameters) + (All [e] (-> (Exception e) e (phase.Operation Lux))) + (..fail' (exception.construct exception parameters))) + +(def: #export (with_stack exception message action) + (All [e o] (-> (Exception e) e (Operation o) (Operation o))) + (function (_ bundle,state) + (case (exception.with exception message + (action bundle,state)) + (#try.Success output) + (#try.Success output) + + (#try.Failure error) + (let [[bundle state] bundle,state] + (#try.Failure (locate_error (get@ #.location state) error)))))) + +(def: #export (install state) + (-> .Lux (Operation Any)) + (function (_ [bundle _]) + (#try.Success [[bundle state] + []]))) + +(template [<name> <type> <field> <value>] + [(def: #export (<name> value) + (-> <type> (Operation Any)) + (extension.update (set@ <field> <value>)))] + + [set_source_code Source #.source value] + [set_current_module Text #.current_module (#.Some value)] + [set_location Location #.location value] + ) + +(def: #export (location file) + (-> Text Location) + [file 1 0]) + +(def: #export (source file code) + (-> Text Text Source) + [(location file) 0 code]) + +(def: dummy_source + Source + [location.dummy 0 ""]) + +(def: type_context + Type_Context + {#.ex_counter 0 + #.var_counter 0 + #.var_bindings (list)}) + +(def: #export (info version host) + (-> Version Text Info) + {#.target host + #.version (%.nat version) + #.mode #.Build}) + +(def: #export (state info) + (-> Info Lux) + {#.info info + #.source ..dummy_source + #.location location.dummy + #.current_module #.None + #.modules (list) + #.scopes (list) + #.type_context ..type_context + #.expected #.None + #.seed 0 + #.scope_type_vars (list) + #.extensions [] + #.host []}) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/evaluation.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/evaluation.lux new file mode 100644 index 000000000..0895955dc --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/evaluation.lux @@ -0,0 +1,57 @@ +(.module: + [library + [lux (#- Module) + ["." meta] + [abstract + [monad (#+ do)]] + [control + ["." try]] + [math + [number + ["n" nat]]]]] + [// (#+ Operation) + [macro (#+ Expander)] + [// + [phase + [".P" extension] + [".P" synthesis] + [".P" analysis + ["." type]] + [// + ["." synthesis] + ["." generation (#+ Context)] + [/// + ["." phase] + [meta + [archive (#+ Archive) + [descriptor (#+ Module)]]]]]]]]) + +(type: #export Eval + (-> Archive Nat Type Code (Operation Any))) + +(def: (context [module_id artifact_id]) + (-> Context Context) + ## TODO: Find a better way that doesn't rely on clever tricks. + [(n.- module_id 0) artifact_id]) + +(def: #export (evaluator expander synthesis_state generation_state generate) + (All [anchor expression artifact] + (-> Expander + synthesis.State+ + (generation.State+ anchor expression artifact) + (generation.Phase anchor expression artifact) + Eval)) + (let [analyze (analysisP.phase expander)] + (function (eval archive count type exprC) + (do phase.monad + [exprA (type.with_type type + (analyze archive exprC)) + module (extensionP.lift + meta.current_module_name)] + (phase.lift (do try.monad + [exprS (|> exprA (synthesisP.phase archive) (phase.run synthesis_state))] + (phase.run generation_state + (do phase.monad + [exprO (generate archive exprS) + module_id (generation.module_id module archive)] + (generation.evaluate! (..context [module_id count]) exprO))))))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/macro.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/macro.lux new file mode 100644 index 000000000..d0957820c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/macro.lux @@ -0,0 +1,52 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." text + ["%" format (#+ format)]]] + ["." meta]]] + [///// + ["." phase]]) + +(exception: #export (expansion_failed {macro Name} {inputs (List Code)} {error Text}) + (exception.report + ["Macro" (%.name macro)] + ["Inputs" (exception.enumerate %.code inputs)] + ["Error" error])) + +(exception: #export (must_have_single_expansion {macro Name} {inputs (List Code)} {outputs (List Code)}) + (exception.report + ["Macro" (%.name macro)] + ["Inputs" (exception.enumerate %.code inputs)] + ["Outputs" (exception.enumerate %.code outputs)])) + +(type: #export Expander + (-> Macro (List Code) Lux (Try (Try [Lux (List Code)])))) + +(def: #export (expand expander name macro inputs) + (-> Expander Name Macro (List Code) (Meta (List Code))) + (function (_ state) + (do try.monad + [output (expander macro inputs state)] + (case output + (#try.Success output) + (#try.Success output) + + (#try.Failure error) + ((meta.fail (exception.construct ..expansion_failed [name inputs error])) state))))) + +(def: #export (expand_one expander name macro inputs) + (-> Expander Name Macro (List Code) (Meta Code)) + (do meta.monad + [expansion (expand expander name macro inputs)] + (case expansion + (^ (list single)) + (wrap single) + + _ + (meta.fail (exception.construct ..must_have_single_expansion [name inputs expansion]))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux new file mode 100644 index 000000000..49ab15299 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux @@ -0,0 +1,83 @@ +(.module: + [library + [lux (#- Module) + [abstract + [monad (#+ do)]] + [data + [collection + ["." list ("#\." monoid)]]]]] + [// + ["." analysis] + ["." synthesis] + ["." generation] + [phase + ["." extension]] + [/// + ["." phase] + [meta + [archive + [descriptor (#+ Module)]]]]]) + +(type: #export (Component state phase) + {#state state + #phase phase}) + +(type: #export (State anchor expression directive) + {#analysis (Component analysis.State+ + analysis.Phase) + #synthesis (Component synthesis.State+ + synthesis.Phase) + #generation (Component (generation.State+ anchor expression directive) + (generation.Phase anchor expression directive))}) + +(type: #export Import + {#module Module + #alias Text}) + +(type: #export Requirements + {#imports (List Import) + #referrals (List Code)}) + +(def: #export no_requirements + Requirements + {#imports (list) + #referrals (list)}) + +(def: #export (merge_requirements left right) + (-> Requirements Requirements Requirements) + {#imports (list\compose (get@ #imports left) (get@ #imports right)) + #referrals (list\compose (get@ #referrals left) (get@ #referrals right))}) + +(template [<special> <general>] + [(type: #export (<special> anchor expression directive) + (<general> (..State anchor expression directive) Code Requirements))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(template [<name> <component> <operation>] + [(def: #export <name> + (All [anchor expression directive output] + (-> (<operation> output) + (Operation anchor expression directive output))) + (|>> (phase.sub [(get@ [<component> #..state]) + (set@ [<component> #..state])]) + extension.lift))] + + [lift_analysis #..analysis analysis.Operation] + [lift_synthesis #..synthesis synthesis.Operation] + [lift_generation #..generation (generation.Operation anchor expression directive)] + ) + +(def: #export (set_current_module module) + (All [anchor expression directive] + (-> Module (Operation anchor expression directive Any))) + (do phase.monad + [_ (..lift_analysis + (analysis.set_current_module module))] + (..lift_generation + (generation.enter_module module)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/library/lux/tool/compiler/language/lux/generation.lux new file mode 100644 index 000000000..13d36021f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/generation.lux @@ -0,0 +1,336 @@ +(.module: + [library + [lux (#- Module) + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["." function]] + [data + [binary (#+ Binary)] + ["." product] + ["." name] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." row (#+ Row)] + ["." list ("#\." functor)]]] + [math + [number + ["n" nat]]]]] + [// + [synthesis (#+ Synthesis)] + [phase + ["." extension]] + [/// + ["." phase] + [meta + ["." archive (#+ Archive) + ["." descriptor (#+ Module)] + ["." artifact]]]]]) + +(type: #export Context + [archive.ID artifact.ID]) + +(type: #export (Buffer directive) + (Row [artifact.ID directive])) + +(exception: #export (cannot_interpret {error Text}) + (exception.report + ["Error" error])) + +(template [<name>] + [(exception: #export (<name> {artifact_id artifact.ID}) + (exception.report + ["Artifact ID" (%.nat artifact_id)]))] + + [cannot_overwrite_output] + [no_buffer_for_saving_code] + ) + +(interface: #export (Host expression directive) + (: (-> Context expression (Try Any)) + evaluate!) + (: (-> directive (Try Any)) + execute!) + (: (-> Context expression (Try [Text Any directive])) + define!) + + (: (-> Context Binary directive) + ingest) + (: (-> Context directive (Try Any)) + re_learn) + (: (-> Context directive (Try Any)) + re_load)) + +(type: #export (State anchor expression directive) + {#module Module + #anchor (Maybe anchor) + #host (Host expression directive) + #buffer (Maybe (Buffer directive)) + #registry artifact.Registry + #counter Nat + #context (Maybe artifact.ID) + #log (Row Text)}) + +(template [<special> <general>] + [(type: #export (<special> anchor expression directive) + (<general> (State anchor expression directive) Synthesis expression))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + [Extender extension.Extender] + ) + +(def: #export (state host module) + (All [anchor expression directive] + (-> (Host expression directive) + Module + (..State anchor expression directive))) + {#module module + #anchor #.None + #host host + #buffer #.None + #registry artifact.empty + #counter 0 + #context #.None + #log row.empty}) + +(def: #export empty_buffer Buffer row.empty) + +(template [<tag> + <with_declaration> <with_type> <with_value> + <set> <get> <get_type> <exception>] + [(exception: #export <exception>) + + (def: #export <with_declaration> + (All [anchor expression directive output] <with_type>) + (function (_ body) + (function (_ [bundle state]) + (case (body [bundle (set@ <tag> (#.Some <with_value>) state)]) + (#try.Success [[bundle' state'] output]) + (#try.Success [[bundle' (set@ <tag> (get@ <tag> state) state')] + output]) + + (#try.Failure error) + (#try.Failure error))))) + + (def: #export <get> + (All [anchor expression directive] + (Operation anchor expression directive <get_type>)) + (function (_ (^@ stateE [bundle state])) + (case (get@ <tag> state) + (#.Some output) + (#try.Success [stateE output]) + + #.None + (exception.throw <exception> [])))) + + (def: #export (<set> value) + (All [anchor expression directive] + (-> <get_type> (Operation anchor expression directive Any))) + (function (_ [bundle state]) + (#try.Success [[bundle (set@ <tag> (#.Some value) state)] + []])))] + + [#anchor + (with_anchor anchor) + (-> anchor (Operation anchor expression directive output) + (Operation anchor expression directive output)) + anchor + set_anchor anchor anchor no_anchor] + + [#buffer + with_buffer + (-> (Operation anchor expression directive output) + (Operation anchor expression directive output)) + ..empty_buffer + set_buffer buffer (Buffer directive) no_active_buffer] + ) + +(def: #export get_registry + (All [anchor expression directive] + (Operation anchor expression directive artifact.Registry)) + (function (_ (^@ stateE [bundle state])) + (#try.Success [stateE (get@ #registry state)]))) + +(def: #export (set_registry value) + (All [anchor expression directive] + (-> artifact.Registry (Operation anchor expression directive Any))) + (function (_ [bundle state]) + (#try.Success [[bundle (set@ #registry value state)] + []]))) + +(def: #export next + (All [anchor expression directive] + (Operation anchor expression directive Nat)) + (do phase.monad + [count (extension.read (get@ #counter)) + _ (extension.update (update@ #counter inc))] + (wrap count))) + +(def: #export (gensym prefix) + (All [anchor expression directive] + (-> Text (Operation anchor expression directive Text))) + (\ phase.monad map (|>> %.nat (format prefix)) ..next)) + +(def: #export (enter_module module) + (All [anchor expression directive] + (-> Module (Operation anchor expression directive Any))) + (extension.update (set@ #module module))) + +(def: #export module + (All [anchor expression directive] + (Operation anchor expression directive Module)) + (extension.read (get@ #module))) + +(def: #export (evaluate! label code) + (All [anchor expression directive] + (-> Context expression (Operation anchor expression directive Any))) + (function (_ (^@ state+ [bundle state])) + (case (\ (get@ #host state) evaluate! label code) + (#try.Success output) + (#try.Success [state+ output]) + + (#try.Failure error) + (exception.throw ..cannot_interpret error)))) + +(def: #export (execute! code) + (All [anchor expression directive] + (-> directive (Operation anchor expression directive Any))) + (function (_ (^@ state+ [bundle state])) + (case (\ (get@ #host state) execute! code) + (#try.Success output) + (#try.Success [state+ output]) + + (#try.Failure error) + (exception.throw ..cannot_interpret error)))) + +(def: #export (define! context code) + (All [anchor expression directive] + (-> Context expression (Operation anchor expression directive [Text Any directive]))) + (function (_ (^@ stateE [bundle state])) + (case (\ (get@ #host state) define! context code) + (#try.Success output) + (#try.Success [stateE output]) + + (#try.Failure error) + (exception.throw ..cannot_interpret error)))) + +(def: #export (save! artifact_id code) + (All [anchor expression directive] + (-> artifact.ID directive (Operation anchor expression directive Any))) + (do {! phase.monad} + [?buffer (extension.read (get@ #buffer))] + (case ?buffer + (#.Some buffer) + ## TODO: Optimize by no longer checking for overwrites... + (if (row.any? (|>> product.left (n.= artifact_id)) buffer) + (phase.throw ..cannot_overwrite_output [artifact_id]) + (extension.update (set@ #buffer (#.Some (row.add [artifact_id code] buffer))))) + + #.None + (phase.throw ..no_buffer_for_saving_code [artifact_id])))) + +(template [<name> <artifact>] + [(def: #export (<name> name) + (All [anchor expression directive] + (-> Text (Operation anchor expression directive artifact.ID))) + (function (_ (^@ stateE [bundle state])) + (let [[id registry'] (<artifact> name (get@ #registry state))] + (#try.Success [[bundle (set@ #registry registry' state)] + id]))))] + + [learn artifact.definition] + [learn_analyser artifact.analyser] + [learn_synthesizer artifact.synthesizer] + [learn_generator artifact.generator] + [learn_directive artifact.directive] + ) + +(exception: #export (unknown_definition {name Name} + {known_definitions (List Text)}) + (exception.report + ["Definition" (name.short name)] + ["Module" (name.module name)] + ["Known Definitions" (exception.enumerate function.identity known_definitions)])) + +(def: #export (remember archive name) + (All [anchor expression directive] + (-> Archive Name (Operation anchor expression directive Context))) + (function (_ (^@ stateE [bundle state])) + (let [[_module _name] name] + (do try.monad + [module_id (archive.id _module archive) + registry (if (text\= (get@ #module state) _module) + (#try.Success (get@ #registry state)) + (do try.monad + [[descriptor document] (archive.find _module archive)] + (#try.Success (get@ #descriptor.registry descriptor))))] + (case (artifact.remember _name registry) + #.None + (exception.throw ..unknown_definition [name (artifact.definitions registry)]) + + (#.Some id) + (#try.Success [stateE [module_id id]])))))) + +(exception: #export no_context) + +(def: #export (module_id module archive) + (All [anchor expression directive] + (-> Module Archive (Operation anchor expression directive archive.ID))) + (function (_ (^@ stateE [bundle state])) + (do try.monad + [module_id (archive.id module archive)] + (wrap [stateE module_id])))) + +(def: #export (context archive) + (All [anchor expression directive] + (-> Archive (Operation anchor expression directive Context))) + (function (_ (^@ stateE [bundle state])) + (case (get@ #context state) + #.None + (exception.throw ..no_context []) + + (#.Some id) + (do try.monad + [module_id (archive.id (get@ #module state) archive)] + (wrap [stateE [module_id id]]))))) + +(def: #export (with_context id body) + (All [anchor expression directive a] + (-> artifact.ID + (Operation anchor expression directive a) + (Operation anchor expression directive a))) + (function (_ [bundle state]) + (do try.monad + [[[bundle' state'] output] (body [bundle (set@ #context (#.Some id) state)])] + (wrap [[bundle' (set@ #context (get@ #context state) state')] + output])))) + +(def: #export (with_new_context archive body) + (All [anchor expression directive a] + (-> Archive (Operation anchor expression directive a) + (Operation anchor expression directive [Context a]))) + (function (_ (^@ stateE [bundle state])) + (let [[id registry'] (artifact.resource (get@ #registry state))] + (do try.monad + [[[bundle' state'] output] (body [bundle (|> state + (set@ #registry registry') + (set@ #context (#.Some id)))]) + module_id (archive.id (get@ #module state) archive)] + (wrap [[bundle' (set@ #context (get@ #context state) state')] + [[module_id id] + output]]))))) + +(def: #export (log! message) + (All [anchor expression directive a] + (-> Text (Operation anchor expression directive Any))) + (function (_ [bundle state]) + (#try.Success [[bundle + (update@ #log (row.add message) state)] + []]))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux new file mode 100644 index 000000000..c35404a68 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux @@ -0,0 +1,144 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." exception (#+ exception:)]] + [data + [text + ["%" format (#+ format)]]] + ["." meta + ["." location]]]] + ["." / #_ + ["#." type] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." function] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + ["/" analysis (#+ Analysis Operation Phase) + ["#." macro (#+ Expander)]] + [/// + ["//" phase] + ["." reference] + [meta + [archive (#+ Archive)]]]]]]) + +(exception: #export (unrecognized_syntax {code Code}) + (exception.report ["Code" (%.code code)])) + +## TODO: Had to split the 'compile' function due to compilation issues +## with old-luxc. Must re-combine all the code ASAP + +(type: (Fix a) + (-> a a)) + +(def: (compile|primitive else code') + (Fix (-> (Code' (Ann Location)) (Operation Analysis))) + (case code' + (^template [<tag> <analyser>] + [(<tag> value) + (<analyser> value)]) + ([#.Bit /primitive.bit] + [#.Nat /primitive.nat] + [#.Int /primitive.int] + [#.Rev /primitive.rev] + [#.Frac /primitive.frac] + [#.Text /primitive.text]) + + _ + (else code'))) + +(def: (compile|structure archive compile else code') + (-> Archive Phase (Fix (-> (Code' (Ann Location)) (Operation Analysis)))) + (case code' + (^ (#.Form (list& [_ (#.Tag tag)] + values))) + (case values + (#.Cons value #.Nil) + (/structure.tagged_sum compile tag archive value) + + _ + (/structure.tagged_sum compile tag archive (` [(~+ values)]))) + + (^ (#.Form (list& [_ (#.Nat lefts)] [_ (#.Bit right?)] + values))) + (case values + (#.Cons value #.Nil) + (/structure.sum compile lefts right? archive value) + + _ + (/structure.sum compile lefts right? archive (` [(~+ values)]))) + + (#.Tag tag) + (/structure.tagged_sum compile tag archive (' [])) + + (^ (#.Tuple (list))) + /primitive.unit + + (^ (#.Tuple (list singleton))) + (compile archive singleton) + + (^ (#.Tuple elems)) + (/structure.product archive compile elems) + + (^ (#.Record pairs)) + (/structure.record archive compile pairs) + + _ + (else code'))) + +(def: (compile|others expander archive compile code') + (-> Expander Archive Phase (-> (Code' (Ann Location)) (Operation Analysis))) + (case code' + (#.Identifier reference) + (/reference.reference reference) + + (^ (#.Form (list [_ (#.Record branches)] input))) + (/case.case compile branches archive input) + + (^ (#.Form (list& [_ (#.Text extension_name)] extension_args))) + (//extension.apply archive compile [extension_name extension_args]) + + (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function_name])] + [_ (#.Identifier ["" arg_name])]))] + body))) + (/function.function compile function_name arg_name archive body) + + (^ (#.Form (list& functionC argsC+))) + (do {! //.monad} + [[functionT functionA] (/type.with_inference + (compile archive functionC))] + (case functionA + (#/.Reference (#reference.Constant def_name)) + (do ! + [?macro (//extension.lift (meta.find_macro def_name))] + (case ?macro + (#.Some macro) + (do ! + [expansion (//extension.lift (/macro.expand_one expander def_name macro argsC+))] + (compile archive expansion)) + + _ + (/function.apply compile argsC+ functionT functionA archive functionC))) + + _ + (/function.apply compile argsC+ functionT functionA archive functionC))) + + _ + (//.throw ..unrecognized_syntax [location.dummy code']))) + +(def: #export (phase expander) + (-> Expander Phase) + (function (compile archive code) + (let [[location code'] code] + ## The location must be set in the state for the sake + ## of having useful error messages. + (/.with_location location + (compile|primitive (compile|structure archive compile + (compile|others expander archive compile)) + code'))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux new file mode 100644 index 000000000..d447b8d1d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux @@ -0,0 +1,325 @@ +(.module: + [library + [lux (#- case) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." maybe] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." fold monoid functor)]]] + [math + [number + ["n" nat]]] + [macro + ["." code]] + ["." type + ["." check]]]] + ["." / #_ + ["#." coverage (#+ Coverage)] + ["/#" // #_ + ["#." scope] + ["#." type] + ["#." structure] + ["/#" // #_ + ["#." extension] + [// + ["/" analysis (#+ Pattern Analysis Operation Phase)] + [/// + ["#" phase]]]]]]) + +(exception: #export (cannot_match_with_pattern {type Type} {pattern Code}) + (exception.report + ["Type" (%.type type)] + ["Pattern" (%.code pattern)])) + +(exception: #export (sum_has_no_case {case Nat} {type Type}) + (exception.report + ["Case" (%.nat case)] + ["Type" (%.type type)])) + +(exception: #export (not_a_pattern {code Code}) + (exception.report ["Code" (%.code code)])) + +(exception: #export (cannot_simplify_for_pattern_matching {type Type}) + (exception.report ["Type" (%.type type)])) + +(exception: #export (non_exhaustive_pattern_matching {input Code} {branches (List [Code Code])} {coverage Coverage}) + (exception.report + ["Input" (%.code input)] + ["Branches" (%.code (code.record branches))] + ["Coverage" (/coverage.%coverage coverage)])) + +(exception: #export (cannot_have_empty_branches {message Text}) + message) + +(def: (re_quantify envs baseT) + (-> (List (List Type)) Type Type) + (.case envs + #.Nil + baseT + + (#.Cons head tail) + (re_quantify tail (#.UnivQ head baseT)))) + +## Type-checking on the input value is done during the analysis of a +## "case" expression, to ensure that the patterns being used make +## sense for the type of the input value. +## Sometimes, that input value is complex, by depending on +## type-variables or quantifications. +## This function makes it easier for "case" analysis to properly +## type-check the input with respect to the patterns. +(def: (simplify_case caseT) + (-> Type (Operation Type)) + (loop [envs (: (List (List Type)) + (list)) + caseT caseT] + (.case caseT + (#.Var id) + (do ///.monad + [?caseT' (//type.with_env + (check.read id))] + (.case ?caseT' + (#.Some caseT') + (recur envs caseT') + + _ + (/.throw ..cannot_simplify_for_pattern_matching caseT))) + + (#.Named name unnamedT) + (recur envs unnamedT) + + (#.UnivQ env unquantifiedT) + (recur (#.Cons env envs) unquantifiedT) + + (#.ExQ _) + (do ///.monad + [[var_id varT] (//type.with_env + check.var)] + (recur envs (maybe.assume (type.apply (list varT) caseT)))) + + (#.Apply inputT funcT) + (.case funcT + (#.Var funcT_id) + (do ///.monad + [funcT' (//type.with_env + (do check.monad + [?funct' (check.read funcT_id)] + (.case ?funct' + (#.Some funct') + (wrap funct') + + _ + (check.throw ..cannot_simplify_for_pattern_matching caseT))))] + (recur envs (#.Apply inputT funcT'))) + + _ + (.case (type.apply (list inputT) funcT) + (#.Some outputT) + (recur envs outputT) + + #.None + (/.throw ..cannot_simplify_for_pattern_matching caseT))) + + (#.Product _) + (|> caseT + type.flatten_tuple + (list\map (re_quantify envs)) + type.tuple + (\ ///.monad wrap)) + + _ + (\ ///.monad wrap (re_quantify envs caseT))))) + +(def: (analyse_primitive type inputT location output next) + (All [a] (-> Type Type Location Pattern (Operation a) (Operation [Pattern a]))) + (/.with_location location + (do ///.monad + [_ (//type.with_env + (check.check inputT type)) + outputA next] + (wrap [output outputA])))) + +## This function handles several concerns at once, but it must be that +## way because those concerns are interleaved when doing +## pattern-matching and they cannot be separated. +## The pattern is analysed in order to get a general feel for what is +## expected of the input value. This, in turn, informs the +## type-checking of the input. +## A kind of "continuation" value is passed around which signifies +## what needs to be done _after_ analysing a pattern. +## In general, this is done to analyse the "body" expression +## associated to a particular pattern _in the context of_ said +## pattern. +## The reason why *context* is important is because patterns may bind +## values to local variables, which may in turn be referenced in the +## body expressions. +## That is why the body must be analysed in the context of the +## pattern, and not separately. +(def: (analyse_pattern num_tags inputT pattern next) + (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) + (.case pattern + [location (#.Identifier ["" name])] + (/.with_location location + (do ///.monad + [outputA (//scope.with_local [name inputT] + next) + idx //scope.next_local] + (wrap [(#/.Bind idx) outputA]))) + + (^template [<type> <input> <output>] + [[location <input>] + (analyse_primitive <type> inputT location (#/.Simple <output>) next)]) + ([Bit (#.Bit pattern_value) (#/.Bit pattern_value)] + [Nat (#.Nat pattern_value) (#/.Nat pattern_value)] + [Int (#.Int pattern_value) (#/.Int pattern_value)] + [Rev (#.Rev pattern_value) (#/.Rev pattern_value)] + [Frac (#.Frac pattern_value) (#/.Frac pattern_value)] + [Text (#.Text pattern_value) (#/.Text pattern_value)] + [Any (#.Tuple #.Nil) #/.Unit]) + + (^ [location (#.Tuple (list singleton))]) + (analyse_pattern #.None inputT singleton next) + + [location (#.Tuple sub_patterns)] + (/.with_location location + (do {! ///.monad} + [inputT' (simplify_case inputT)] + (.case inputT' + (#.Product _) + (let [subs (type.flatten_tuple inputT') + num_subs (maybe.default (list.size subs) + num_tags) + num_sub_patterns (list.size sub_patterns) + matches (cond (n.< num_subs num_sub_patterns) + (let [[prefix suffix] (list.split (dec num_sub_patterns) subs)] + (list.zip/2 (list\compose prefix (list (type.tuple suffix))) sub_patterns)) + + (n.> num_subs num_sub_patterns) + (let [[prefix suffix] (list.split (dec num_subs) sub_patterns)] + (list.zip/2 subs (list\compose prefix (list (code.tuple suffix))))) + + ## (n.= num_subs num_sub_patterns) + (list.zip/2 subs sub_patterns))] + (do ! + [[memberP+ thenA] (list\fold (: (All [a] + (-> [Type Code] (Operation [(List Pattern) a]) + (Operation [(List Pattern) a]))) + (function (_ [memberT memberC] then) + (do ! + [[memberP [memberP+ thenA]] ((:as (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) + analyse_pattern) + #.None memberT memberC then)] + (wrap [(list& memberP memberP+) thenA])))) + (do ! + [nextA next] + (wrap [(list) nextA])) + (list.reverse matches))] + (wrap [(/.pattern/tuple memberP+) + thenA]))) + + _ + (/.throw ..cannot_match_with_pattern [inputT' pattern]) + ))) + + [location (#.Record record)] + (do ///.monad + [record (//structure.normalize record) + [members recordT] (//structure.order record) + _ (.case inputT + (#.Var _id) + (//type.with_env + (check.check inputT recordT)) + + _ + (wrap []))] + (analyse_pattern (#.Some (list.size members)) inputT [location (#.Tuple members)] next)) + + [location (#.Tag tag)] + (/.with_location location + (analyse_pattern #.None inputT (` ((~ pattern))) next)) + + (^ [location (#.Form (list& [_ (#.Nat lefts)] [_ (#.Bit right?)] values))]) + (/.with_location location + (do ///.monad + [inputT' (simplify_case inputT)] + (.case inputT' + (#.Sum _) + (let [flat_sum (type.flatten_variant inputT') + size_sum (list.size flat_sum) + num_cases (maybe.default size_sum num_tags) + idx (/.tag lefts right?)] + (.case (list.nth idx flat_sum) + (^multi (#.Some caseT) + (n.< num_cases idx)) + (do ///.monad + [[testP nextA] (if (and (n.> num_cases size_sum) + (n.= (dec num_cases) idx)) + (analyse_pattern #.None + (type.variant (list.drop (dec num_cases) flat_sum)) + (` [(~+ values)]) + next) + (analyse_pattern #.None caseT (` [(~+ values)]) next))] + (wrap [(/.pattern/variant [lefts right? testP]) + nextA])) + + _ + (/.throw ..sum_has_no_case [idx inputT]))) + + (#.UnivQ _) + (do ///.monad + [[ex_id exT] (//type.with_env + check.existential)] + (analyse_pattern num_tags + (maybe.assume (type.apply (list exT) inputT')) + pattern + next)) + + _ + (/.throw ..cannot_match_with_pattern [inputT' pattern])))) + + (^ [location (#.Form (list& [_ (#.Tag tag)] values))]) + (/.with_location location + (do ///.monad + [tag (///extension.lift (meta.normalize tag)) + [idx group variantT] (///extension.lift (meta.resolve_tag tag)) + _ (//type.with_env + (check.check inputT variantT)) + #let [[lefts right?] (/.choice (list.size group) idx)]] + (analyse_pattern (#.Some (list.size group)) inputT (` ((~ (code.nat lefts)) (~ (code.bit right?)) (~+ values))) next))) + + _ + (/.throw ..not_a_pattern pattern) + )) + +(def: #export (case analyse branches archive inputC) + (-> Phase (List [Code Code]) Phase) + (.case branches + (#.Cons [patternH bodyH] branchesT) + (do {! ///.monad} + [[inputT inputA] (//type.with_inference + (analyse archive inputC)) + outputH (analyse_pattern #.None inputT patternH (analyse archive bodyH)) + outputT (monad.map ! + (function (_ [patternT bodyT]) + (analyse_pattern #.None inputT patternT (analyse archive bodyT))) + branchesT) + outputHC (|> outputH product.left /coverage.determine) + outputTC (monad.map ! (|>> product.left /coverage.determine) outputT) + _ (.case (monad.fold try.monad /coverage.merge outputHC outputTC) + (#try.Success coverage) + (///.assert non_exhaustive_pattern_matching [inputC branches coverage] + (/coverage.exhaustive? coverage)) + + (#try.Failure error) + (/.fail error))] + (wrap (#/.Case inputA [outputH outputT]))) + + #.Nil + (/.throw ..cannot_have_empty_branches ""))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux new file mode 100644 index 000000000..df92858ec --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux @@ -0,0 +1,373 @@ +(.module: + [library + [lux #* + [abstract + equivalence + ["." monad (#+ do)]] + [control + ["." try (#+ Try) ("#\." monad)] + ["ex" exception (#+ exception:)]] + [data + ["." bit ("#\." equivalence)] + ["." maybe] + ["." text + ["%" format (#+ Format format)]] + [collection + ["." list ("#\." functor fold)] + ["." dictionary (#+ Dictionary)]]] + [math + [number + ["n" nat]]]]] + ["." //// #_ + [// + ["/" analysis (#+ Pattern Variant Operation)] + [/// + ["#" phase ("#\." monad)]]]]) + +(exception: #export (invalid_tuple_pattern) + "Tuple size must be >= 2") + +(def: cases + (-> (Maybe Nat) Nat) + (|>> (maybe.default 0))) + +(def: known_cases? + (-> Nat Bit) + (n.> 0)) + +## The coverage of a pattern-matching expression summarizes how well +## all the possible values of an input are being covered by the +## different patterns involved. +## Ideally, the pattern-matching has "exhaustive" coverage, which just +## means that every possible value can be matched by at least 1 +## pattern. +## Every other coverage is considered partial, and it would be valued +## as insuficient (since it could lead to runtime errors due to values +## not being handled by any pattern). +## The #Partial tag covers arbitrary partial coverages in a general +## way, while the other tags cover more specific cases for bits +## and variants. +(type: #export #rec Coverage + #Partial + (#Bit Bit) + (#Variant (Maybe Nat) (Dictionary Nat Coverage)) + (#Seq Coverage Coverage) + (#Alt Coverage Coverage) + #Exhaustive) + +(def: #export (exhaustive? coverage) + (-> Coverage Bit) + (case coverage + (#Exhaustive _) + #1 + + _ + #0)) + +(def: #export (%coverage value) + (Format Coverage) + (case value + #Partial + "#Partial" + + (#Bit value') + (|> value' + %.bit + (text.enclose ["(#Bit " ")"])) + + (#Variant ?max_cases cases) + (|> cases + dictionary.entries + (list\map (function (_ [idx coverage]) + (format (%.nat idx) " " (%coverage coverage)))) + (text.join_with " ") + (text.enclose ["{" "}"]) + (format (%.nat (..cases ?max_cases)) " ") + (text.enclose ["(#Variant " ")"])) + + (#Seq left right) + (format "(#Seq " (%coverage left) " " (%coverage right) ")") + + (#Alt left right) + (format "(#Alt " (%coverage left) " " (%coverage right) ")") + + #Exhaustive + "#Exhaustive")) + +(def: #export (determine pattern) + (-> Pattern (Operation Coverage)) + (case pattern + (^or (#/.Simple #/.Unit) + (#/.Bind _)) + (////\wrap #Exhaustive) + + ## Primitive patterns always have partial coverage because there + ## are too many possibilities as far as values go. + (^template [<tag>] + [(#/.Simple (<tag> _)) + (////\wrap #Partial)]) + ([#/.Nat] + [#/.Int] + [#/.Rev] + [#/.Frac] + [#/.Text]) + + ## Bits are the exception, since there is only "#1" and + ## "#0", which means it is possible for bit + ## pattern-matching to become exhaustive if complementary parts meet. + (#/.Simple (#/.Bit value)) + (////\wrap (#Bit value)) + + ## Tuple patterns can be exhaustive if there is exhaustiveness for all of + ## their sub-patterns. + (#/.Complex (#/.Tuple membersP+)) + (case (list.reverse membersP+) + (^or #.Nil (#.Cons _ #.Nil)) + (/.throw ..invalid_tuple_pattern []) + + (#.Cons lastP prevsP+) + (do ////.monad + [lastC (determine lastP)] + (monad.fold ////.monad + (function (_ leftP rightC) + (do ////.monad + [leftC (determine leftP)] + (case rightC + #Exhaustive + (wrap leftC) + + _ + (wrap (#Seq leftC rightC))))) + lastC prevsP+))) + + ## Variant patterns can be shown to be exhaustive if all the possible + ## cases are handled exhaustively. + (#/.Complex (#/.Variant [lefts right? value])) + (do ////.monad + [value_coverage (determine value) + #let [idx (if right? + (inc lefts) + lefts)]] + (wrap (#Variant (if right? + (#.Some idx) + #.None) + (|> (dictionary.new n.hash) + (dictionary.put idx value_coverage))))))) + +(def: (xor left right) + (-> Bit Bit Bit) + (or (and left (not right)) + (and (not left) right))) + +## The coverage checker not only verifies that pattern-matching is +## exhaustive, but also that there are no redundant patterns. +## Redundant patterns will never be executed, since there will +## always be a pattern prior to them that would match the input. +## Because of that, the presence of redundant patterns is assumed to +## be a bug, likely due to programmer carelessness. +(exception: #export (redundant_pattern {so_far Coverage} {addition Coverage}) + (ex.report ["Coverage so-far" (%coverage so_far)] + ["Coverage addition" (%coverage addition)])) + +(def: (flatten_alt coverage) + (-> Coverage (List Coverage)) + (case coverage + (#Alt left right) + (list& left (flatten_alt right)) + + _ + (list coverage))) + +(implementation: equivalence (Equivalence Coverage) + (def: (= reference sample) + (case [reference sample] + [#Exhaustive #Exhaustive] + #1 + + [(#Bit sideR) (#Bit sideS)] + (bit\= sideR sideS) + + [(#Variant allR casesR) (#Variant allS casesS)] + (and (n.= (cases allR) + (cases allS)) + (\ (dictionary.equivalence =) = casesR casesS)) + + [(#Seq leftR rightR) (#Seq leftS rightS)] + (and (= leftR leftS) + (= rightR rightS)) + + [(#Alt _) (#Alt _)] + (let [flatR (flatten_alt reference) + flatS (flatten_alt sample)] + (and (n.= (list.size flatR) (list.size flatS)) + (list.every? (function (_ [coverageR coverageS]) + (= coverageR coverageS)) + (list.zip/2 flatR flatS)))) + + _ + #0))) + +(open: "coverage/." ..equivalence) + +(exception: #export (variants_do_not_match {addition_cases Nat} {so_far_cases Nat}) + (ex.report ["So-far Cases" (%.nat so_far_cases)] + ["Addition Cases" (%.nat addition_cases)])) + +## After determining the coverage of each individual pattern, it is +## necessary to merge them all to figure out if the entire +## pattern-matching expression is exhaustive and whether it contains +## redundant patterns. +(def: #export (merge addition so_far) + (-> Coverage Coverage (Try Coverage)) + (case [addition so_far] + [#Partial #Partial] + (try\wrap #Partial) + + ## 2 bit coverages are exhaustive if they complement one another. + (^multi [(#Bit sideA) (#Bit sideSF)] + (xor sideA sideSF)) + (try\wrap #Exhaustive) + + [(#Variant allA casesA) (#Variant allSF casesSF)] + (let [addition_cases (cases allSF) + so_far_cases (cases allA)] + (cond (and (known_cases? addition_cases) + (known_cases? so_far_cases) + (not (n.= addition_cases so_far_cases))) + (ex.throw ..variants_do_not_match [addition_cases so_far_cases]) + + (\ (dictionary.equivalence ..equivalence) = casesSF casesA) + (ex.throw ..redundant_pattern [so_far addition]) + + ## else + (do {! try.monad} + [casesM (monad.fold ! + (function (_ [tagA coverageA] casesSF') + (case (dictionary.get tagA casesSF') + (#.Some coverageSF) + (do ! + [coverageM (merge coverageA coverageSF)] + (wrap (dictionary.put tagA coverageM casesSF'))) + + #.None + (wrap (dictionary.put tagA coverageA casesSF')))) + casesSF (dictionary.entries casesA))] + (wrap (if (and (or (known_cases? addition_cases) + (known_cases? so_far_cases)) + (n.= (inc (n.max addition_cases so_far_cases)) + (dictionary.size casesM)) + (list.every? exhaustive? (dictionary.values casesM))) + #Exhaustive + (#Variant (case allSF + (#.Some _) + allSF + + _ + allA) + casesM)))))) + + [(#Seq leftA rightA) (#Seq leftSF rightSF)] + (case [(coverage/= leftSF leftA) (coverage/= rightSF rightA)] + ## Same prefix + [#1 #0] + (do try.monad + [rightM (merge rightA rightSF)] + (if (exhaustive? rightM) + ## If all that follows is exhaustive, then it can be safely dropped + ## (since only the "left" part would influence whether the + ## merged coverage is exhaustive or not). + (wrap leftSF) + (wrap (#Seq leftSF rightM)))) + + ## Same suffix + [#0 #1] + (do try.monad + [leftM (merge leftA leftSF)] + (wrap (#Seq leftM rightA))) + + ## The 2 sequences cannot possibly be merged. + [#0 #0] + (try\wrap (#Alt so_far addition)) + + ## There is nothing the addition adds to the coverage. + [#1 #1] + (ex.throw ..redundant_pattern [so_far addition])) + + ## The addition cannot possibly improve the coverage. + [_ #Exhaustive] + (ex.throw ..redundant_pattern [so_far addition]) + + ## The addition completes the coverage. + [#Exhaustive _] + (try\wrap #Exhaustive) + + ## The left part will always match, so the addition is redundant. + (^multi [(#Seq left right) single] + (coverage/= left single)) + (ex.throw ..redundant_pattern [so_far addition]) + + ## The right part is not necessary, since it can always match the left. + (^multi [single (#Seq left right)] + (coverage/= left single)) + (try\wrap single) + + ## When merging a new coverage against one based on Alt, it may be + ## that one of the many coverages in the Alt is complementary to + ## the new one, so effort must be made to fuse carefully, to match + ## the right coverages together. + ## If one of the Alt sub-coverages matches the new one, the cycle + ## must be repeated, in case the resulting coverage can now match + ## other ones in the original Alt. + ## This process must be repeated until no further productive + ## merges can be done. + [_ (#Alt leftS rightS)] + (do {! try.monad} + [#let [fuse_once (: (-> Coverage (List Coverage) + (Try [(Maybe Coverage) + (List Coverage)])) + (function (_ coverageA possibilitiesSF) + (loop [altsSF possibilitiesSF] + (case altsSF + #.Nil + (wrap [#.None (list coverageA)]) + + (#.Cons altSF altsSF') + (case (merge coverageA altSF) + (#try.Success altMSF) + (case altMSF + (#Alt _) + (do ! + [[success altsSF+] (recur altsSF')] + (wrap [success (#.Cons altSF altsSF+)])) + + _ + (wrap [(#.Some altMSF) altsSF'])) + + (#try.Failure error) + (try.fail error)) + ))))] + [successA possibilitiesSF] (fuse_once addition (flatten_alt so_far))] + (loop [successA successA + possibilitiesSF possibilitiesSF] + (case successA + (#.Some coverageA') + (do ! + [[successA' possibilitiesSF'] (fuse_once coverageA' possibilitiesSF)] + (recur successA' possibilitiesSF')) + + #.None + (case (list.reverse possibilitiesSF) + (#.Cons last prevs) + (wrap (list\fold (function (_ left right) (#Alt left right)) + last + prevs)) + + #.Nil + (undefined))))) + + _ + (if (coverage/= so_far addition) + ## The addition cannot possibly improve the coverage. + (ex.throw ..redundant_pattern [so_far addition]) + ## There are now 2 alternative paths. + (try\wrap (#Alt so_far addition))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/function.lux new file mode 100644 index 000000000..5e41e907e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/function.lux @@ -0,0 +1,113 @@ +(.module: + [library + [lux (#- function) + [abstract + monad] + [control + ["ex" exception (#+ exception:)]] + [data + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." fold monoid monad)]]] + ["." type + ["." check]] + ["." meta]]] + ["." // #_ + ["#." scope] + ["#." type] + ["#." inference] + ["/#" // #_ + ["#." extension] + [// + ["/" analysis (#+ Analysis Operation Phase)] + [/// + ["#" phase] + [reference (#+) + [variable (#+)]]]]]]) + +(exception: #export (cannot_analyse {expected Type} {function Text} {argument Text} {body Code}) + (ex.report ["Type" (%.type expected)] + ["Function" function] + ["Argument" argument] + ["Body" (%.code body)])) + +(exception: #export (cannot_apply {functionT Type} {functionC Code} {arguments (List Code)}) + (ex.report ["Function type" (%.type functionT)] + ["Function" (%.code functionC)] + ["Arguments" (|> arguments + list.enumeration + (list\map (.function (_ [idx argC]) + (format (%.nat idx) " " (%.code argC)))) + (text.join_with text.new_line))])) + +(def: #export (function analyse function_name arg_name archive body) + (-> Phase Text Text Phase) + (do {! ///.monad} + [functionT (///extension.lift meta.expected_type)] + (loop [expectedT functionT] + (/.with_stack ..cannot_analyse [expectedT function_name arg_name body] + (case expectedT + (#.Named name unnamedT) + (recur unnamedT) + + (#.Apply argT funT) + (case (type.apply (list argT) funT) + (#.Some value) + (recur value) + + #.None + (/.fail (ex.construct cannot_analyse [expectedT function_name arg_name body]))) + + (^template [<tag> <instancer>] + [(<tag> _) + (do ! + [[_ instanceT] (//type.with_env <instancer>)] + (recur (maybe.assume (type.apply (list instanceT) expectedT))))]) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Var id) + (do ! + [?expectedT' (//type.with_env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (recur expectedT') + + ## Inference + _ + (do ! + [[input_id inputT] (//type.with_env check.var) + [output_id outputT] (//type.with_env check.var) + #let [functionT (#.Function inputT outputT)] + functionA (recur functionT) + _ (//type.with_env + (check.check expectedT functionT))] + (wrap functionA)) + )) + + (#.Function inputT outputT) + (<| (\ ! map (.function (_ [scope bodyA]) + (#/.Function (list\map (|>> /.variable) + (//scope.environment scope)) + bodyA))) + /.with_scope + ## Functions have access not only to their argument, but + ## also to themselves, through a local variable. + (//scope.with_local [function_name expectedT]) + (//scope.with_local [arg_name inputT]) + (//type.with_type outputT) + (analyse archive body)) + + _ + (/.fail "") + ))))) + +(def: #export (apply analyse argsC+ functionT functionA archive functionC) + (-> Phase (List Code) Type Analysis Phase) + (<| (/.with_stack ..cannot_apply [functionT functionC argsC+]) + (do ///.monad + [[applyT argsA+] (//inference.general archive analyse functionT argsC+)]) + (wrap (/.apply [functionA argsA+])))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/inference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/inference.lux new file mode 100644 index 000000000..9ad503709 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/inference.lux @@ -0,0 +1,301 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." exception (#+ exception:)]] + [data + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)]]] + [math + [number + ["n" nat]]] + ["." type + ["." check]] + ["." meta]]] + ["." // #_ + ["#." type] + ["/#" // #_ + ["#." extension] + [// + ["/" analysis (#+ Tag Analysis Operation Phase)] + [/// + ["#" phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]) + +(exception: #export (variant_tag_out_of_bounds {size Nat} {tag Tag} {type Type}) + (exception.report + ["Tag" (%.nat tag)] + ["Variant size" (%.int (.int size))] + ["Variant type" (%.type type)])) + +(exception: #export (cannot_infer {type Type} {args (List Code)}) + (exception.report + ["Type" (%.type type)] + ["Arguments" (exception.enumerate %.code args)])) + +(exception: #export (cannot_infer_argument {inferred Type} {argument Code}) + (exception.report + ["Inferred Type" (%.type inferred)] + ["Argument" (%.code argument)])) + +(exception: #export (smaller_variant_than_expected {expected Nat} {actual Nat}) + (exception.report + ["Expected" (%.int (.int expected))] + ["Actual" (%.int (.int actual))])) + +(template [<name>] + [(exception: #export (<name> {type Type}) + (%.type type))] + + [not_a_variant_type] + [not_a_record_type] + [invalid_type_application] + ) + +(def: (replace parameter_idx replacement type) + (-> Nat Type Type Type) + (case type + (#.Primitive name params) + (#.Primitive name (list\map (replace parameter_idx replacement) params)) + + (^template [<tag>] + [(<tag> left right) + (<tag> (replace parameter_idx replacement left) + (replace parameter_idx replacement right))]) + ([#.Sum] + [#.Product] + [#.Function] + [#.Apply]) + + (#.Parameter idx) + (if (n.= parameter_idx idx) + replacement + type) + + (^template [<tag>] + [(<tag> env quantified) + (<tag> (list\map (replace parameter_idx replacement) env) + (replace (n.+ 2 parameter_idx) replacement quantified))]) + ([#.UnivQ] + [#.ExQ]) + + _ + type)) + +(def: (named_type location id) + (-> Location Nat Type) + (let [name (format "{New Type " (%.location location) " " (%.nat id) "}")] + (#.Primitive name (list)))) + +(def: new_named_type + (Operation Type) + (do ///.monad + [location (///extension.lift meta.location) + [ex_id _] (//type.with_env check.existential)] + (wrap (named_type location ex_id)))) + +## Type-inference works by applying some (potentially quantified) type +## to a sequence of values. +## Function types are used for this, although inference is not always +## done for function application (alternative uses may be records and +## tagged variants). +## But, so long as the type being used for the inference can be treated +## as a function type, this method of inference should work. +(def: #export (general archive analyse inferT args) + (-> Archive Phase Type (List Code) (Operation [Type (List Analysis)])) + (case args + #.Nil + (do ///.monad + [_ (//type.infer inferT)] + (wrap [inferT (list)])) + + (#.Cons argC args') + (case inferT + (#.Named name unnamedT) + (general archive analyse unnamedT args) + + (#.UnivQ _) + (do ///.monad + [[var_id varT] (//type.with_env check.var)] + (general archive analyse (maybe.assume (type.apply (list varT) inferT)) args)) + + (#.ExQ _) + (do {! ///.monad} + [[var_id varT] (//type.with_env check.var) + output (general archive analyse + (maybe.assume (type.apply (list varT) inferT)) + args) + bound? (//type.with_env + (check.bound? var_id)) + _ (if bound? + (wrap []) + (do ! + [newT new_named_type] + (//type.with_env + (check.check varT newT))))] + (wrap output)) + + (#.Apply inputT transT) + (case (type.apply (list inputT) transT) + (#.Some outputT) + (general archive analyse outputT args) + + #.None + (/.throw ..invalid_type_application inferT)) + + ## Arguments are inferred back-to-front because, by convention, + ## Lux functions take the most important arguments *last*, which + ## means that the most information for doing proper inference is + ## located in the last arguments to a function call. + ## By inferring back-to-front, a lot of type-annotations can be + ## avoided in Lux code, since the inference algorithm can piece + ## things together more easily. + (#.Function inputT outputT) + (do ///.monad + [[outputT' args'A] (general archive analyse outputT args') + argA (<| (/.with_stack ..cannot_infer_argument [inputT argC]) + (//type.with_type inputT) + (analyse archive argC))] + (wrap [outputT' (list& argA args'A)])) + + (#.Var infer_id) + (do ///.monad + [?inferT' (//type.with_env (check.read infer_id))] + (case ?inferT' + (#.Some inferT') + (general archive analyse inferT' args) + + _ + (/.throw ..cannot_infer [inferT args]))) + + _ + (/.throw ..cannot_infer [inferT args])) + )) + +(def: (substitute_bound target sub) + (-> Nat Type Type Type) + (function (recur base) + (case base + (#.Primitive name parameters) + (#.Primitive name (list\map recur parameters)) + + (^template [<tag>] + [(<tag> left right) + (<tag> (recur left) (recur right))]) + ([#.Sum] [#.Product] [#.Function] [#.Apply]) + + (#.Parameter index) + (if (n.= target index) + sub + base) + + (^template [<tag>] + [(<tag> environment quantified) + (<tag> (list\map recur environment) quantified)]) + ([#.UnivQ] [#.ExQ]) + + _ + base))) + +## Turns a record type into the kind of function type suitable for inference. +(def: (record' target originalT inferT) + (-> Nat Type Type (Operation Type)) + (case inferT + (#.Named name unnamedT) + (record' target originalT unnamedT) + + (^template [<tag>] + [(<tag> env bodyT) + (do ///.monad + [bodyT+ (record' (n.+ 2 target) originalT bodyT)] + (wrap (<tag> env bodyT+)))]) + ([#.UnivQ] + [#.ExQ]) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (record' target originalT outputT) + + #.None + (/.throw ..invalid_type_application inferT)) + + (#.Product _) + (///\wrap (|> inferT + (type.function (type.flatten_tuple inferT)) + (substitute_bound target originalT))) + + _ + (/.throw ..not_a_record_type inferT))) + +(def: #export (record inferT) + (-> Type (Operation Type)) + (record' (n.- 2 0) inferT inferT)) + +## Turns a variant type into the kind of function type suitable for inference. +(def: #export (variant tag expected_size inferT) + (-> Nat Nat Type (Operation Type)) + (loop [depth 0 + currentT inferT] + (case currentT + (#.Named name unnamedT) + (do ///.monad + [unnamedT+ (recur depth unnamedT)] + (wrap unnamedT+)) + + (^template [<tag>] + [(<tag> env bodyT) + (do ///.monad + [bodyT+ (recur (inc depth) bodyT)] + (wrap (<tag> env bodyT+)))]) + ([#.UnivQ] + [#.ExQ]) + + (#.Sum _) + (let [cases (type.flatten_variant currentT) + actual_size (list.size cases) + boundary (dec expected_size)] + (cond (or (n.= expected_size actual_size) + (and (n.> expected_size actual_size) + (n.< boundary tag))) + (case (list.nth tag cases) + (#.Some caseT) + (///\wrap (if (n.= 0 depth) + (type.function (list caseT) currentT) + (let [replace' (replace (|> depth dec (n.* 2)) inferT)] + (type.function (list (replace' caseT)) + (replace' currentT))))) + + #.None + (/.throw ..variant_tag_out_of_bounds [expected_size tag inferT])) + + (n.< expected_size actual_size) + (/.throw ..smaller_variant_than_expected [expected_size actual_size]) + + (n.= boundary tag) + (let [caseT (type.variant (list.drop boundary cases))] + (///\wrap (if (n.= 0 depth) + (type.function (list caseT) currentT) + (let [replace' (replace (|> depth dec (n.* 2)) inferT)] + (type.function (list (replace' caseT)) + (replace' currentT)))))) + + ## else + (/.throw ..variant_tag_out_of_bounds [expected_size tag inferT]))) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (variant tag expected_size outputT) + + #.None + (/.throw ..invalid_type_application inferT)) + + _ + (/.throw ..not_a_variant_type inferT)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux new file mode 100644 index 000000000..94b289a08 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux @@ -0,0 +1,275 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + pipe + ["." try] + ["." exception (#+ exception:)]] + [data + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." list ("#\." fold functor)] + [dictionary + ["." plist]]]] + ["." meta]]] + ["." /// #_ + ["#." extension] + [// + ["/" analysis (#+ Operation)] + [/// + ["#" phase]]]]) + +(type: #export Tag Text) + +(exception: #export (unknown_module {module Text}) + (exception.report + ["Module" module])) + +(exception: #export (cannot_declare_tag_twice {module Text} {tag Text}) + (exception.report + ["Module" module] + ["Tag" tag])) + +(template [<name>] + [(exception: #export (<name> {tags (List Text)} {owner Type}) + (exception.report + ["Tags" (text.join_with " " tags)] + ["Type" (%.type owner)]))] + + [cannot_declare_tags_for_unnamed_type] + [cannot_declare_tags_for_foreign_type] + ) + +(exception: #export (cannot_define_more_than_once {name Name} {already_existing Global}) + (exception.report + ["Definition" (%.name name)] + ["Original" (case already_existing + (#.Alias alias) + (format "alias " (%.name alias)) + + (#.Definition definition) + (format "definition " (%.name name)))])) + +(exception: #export (can_only_change_state_of_active_module {module Text} {state Module_State}) + (exception.report + ["Module" module] + ["Desired state" (case state + #.Active "Active" + #.Compiled "Compiled" + #.Cached "Cached")])) + +(exception: #export (cannot_set_module_annotations_more_than_once {module Text} {old Code} {new Code}) + (exception.report + ["Module" module] + ["Old annotations" (%.code old)] + ["New annotations" (%.code new)])) + +(def: #export (new hash) + (-> Nat Module) + {#.module_hash hash + #.module_aliases (list) + #.definitions (list) + #.imports (list) + #.tags (list) + #.types (list) + #.module_annotations #.None + #.module_state #.Active}) + +(def: #export (set_annotations annotations) + (-> Code (Operation Any)) + (///extension.lift + (do ///.monad + [self_name meta.current_module_name + self meta.current_module] + (case (get@ #.module_annotations self) + #.None + (function (_ state) + (#try.Success [(update@ #.modules + (plist.put self_name (set@ #.module_annotations (#.Some annotations) self)) + state) + []])) + + (#.Some old) + (/.throw' cannot_set_module_annotations_more_than_once [self_name old annotations]))))) + +(def: #export (import module) + (-> Text (Operation Any)) + (///extension.lift + (do ///.monad + [self_name meta.current_module_name] + (function (_ state) + (#try.Success [(update@ #.modules + (plist.update self_name (update@ #.imports (function (_ current) + (if (list.any? (text\= module) + current) + current + (#.Cons module current))))) + state) + []]))))) + +(def: #export (alias alias module) + (-> Text Text (Operation Any)) + (///extension.lift + (do ///.monad + [self_name meta.current_module_name] + (function (_ state) + (#try.Success [(update@ #.modules + (plist.update self_name (update@ #.module_aliases (: (-> (List [Text Text]) (List [Text Text])) + (|>> (#.Cons [alias module]))))) + state) + []]))))) + +(def: #export (exists? module) + (-> Text (Operation Bit)) + (///extension.lift + (function (_ state) + (|> state + (get@ #.modules) + (plist.get module) + (case> (#.Some _) #1 #.None #0) + [state] #try.Success)))) + +(def: #export (define name definition) + (-> Text Global (Operation Any)) + (///extension.lift + (do ///.monad + [self_name meta.current_module_name + self meta.current_module] + (function (_ state) + (case (plist.get name (get@ #.definitions self)) + #.None + (#try.Success [(update@ #.modules + (plist.put self_name + (update@ #.definitions + (: (-> (List [Text Global]) (List [Text Global])) + (|>> (#.Cons [name definition]))) + self)) + state) + []]) + + (#.Some already_existing) + ((/.throw' ..cannot_define_more_than_once [[self_name name] already_existing]) state)))))) + +(def: #export (create hash name) + (-> Nat Text (Operation Any)) + (///extension.lift + (function (_ state) + (#try.Success [(update@ #.modules + (plist.put name (new hash)) + state) + []])))) + +(def: #export (with_module hash name action) + (All [a] (-> Nat Text (Operation a) (Operation [Module a]))) + (do ///.monad + [_ (create hash name) + output (/.with_current_module name + action) + module (///extension.lift (meta.find_module name))] + (wrap [module output]))) + +(template [<setter> <asker> <tag>] + [(def: #export (<setter> module_name) + (-> Text (Operation Any)) + (///extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module_name)) + (#.Some module) + (let [active? (case (get@ #.module_state module) + #.Active #1 + _ #0)] + (if active? + (#try.Success [(update@ #.modules + (plist.put module_name (set@ #.module_state <tag> module)) + state) + []]) + ((/.throw' can_only_change_state_of_active_module [module_name <tag>]) + state))) + + #.None + ((/.throw' unknown_module module_name) state))))) + + (def: #export (<asker> module_name) + (-> Text (Operation Bit)) + (///extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module_name)) + (#.Some module) + (#try.Success [state + (case (get@ #.module_state module) + <tag> #1 + _ #0)]) + + #.None + ((/.throw' unknown_module module_name) state)))))] + + [set_active active? #.Active] + [set_compiled compiled? #.Compiled] + [set_cached cached? #.Cached] + ) + +(template [<name> <tag> <type>] + [(def: (<name> module_name) + (-> Text (Operation <type>)) + (///extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module_name)) + (#.Some module) + (#try.Success [state (get@ <tag> module)]) + + #.None + ((/.throw' unknown_module module_name) state)))))] + + [tags #.tags (List [Text [Nat (List Name) Bit Type]])] + [types #.types (List [Text [(List Name) Bit Type]])] + [hash #.module_hash Nat] + ) + +(def: (ensure_undeclared_tags module_name tags) + (-> Text (List Tag) (Operation Any)) + (do {! ///.monad} + [bindings (..tags module_name) + _ (monad.map ! + (function (_ tag) + (case (plist.get tag bindings) + #.None + (wrap []) + + (#.Some _) + (/.throw ..cannot_declare_tag_twice [module_name tag]))) + tags)] + (wrap []))) + +(def: #export (declare_tags tags exported? type) + (-> (List Tag) Bit Type (Operation Any)) + (do ///.monad + [self_name (///extension.lift meta.current_module_name) + [type_module type_name] (case type + (#.Named type_name _) + (wrap type_name) + + _ + (/.throw ..cannot_declare_tags_for_unnamed_type [tags type])) + _ (ensure_undeclared_tags self_name tags) + _ (///.assert cannot_declare_tags_for_foreign_type [tags type] + (text\= self_name type_module))] + (///extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get self_name)) + (#.Some module) + (let [namespaced_tags (list\map (|>> [self_name]) tags)] + (#try.Success [(update@ #.modules + (plist.update self_name + (|>> (update@ #.tags (function (_ tag_bindings) + (list\fold (function (_ [idx tag] table) + (plist.put tag [idx namespaced_tags exported? type] table)) + tag_bindings + (list.enumeration tags)))) + (update@ #.types (plist.put type_name [namespaced_tags exported? type])))) + state) + []])) + #.None + ((/.throw' unknown_module self_name) state)))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/primitive.lux new file mode 100644 index 000000000..27c4d98f4 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/primitive.lux @@ -0,0 +1,33 @@ +(.module: + [library + [lux (#- nat int rev) + [abstract + monad]]] + ["." // #_ + ["#." type] + ["/#" // #_ + [// + ["/" analysis (#+ Analysis Operation)] + [/// + ["#" phase]]]]]) + +(template [<name> <type> <tag>] + [(def: #export (<name> value) + (-> <type> (Operation Analysis)) + (do ///.monad + [_ (//type.infer <type>)] + (wrap (#/.Primitive (<tag> value)))))] + + [bit .Bit #/.Bit] + [nat .Nat #/.Nat] + [int .Int #/.Int] + [rev .Rev #/.Rev] + [frac .Frac #/.Frac] + [text .Text #/.Text] + ) + +(def: #export unit + (Operation Analysis) + (do ///.monad + [_ (//type.infer .Any)] + (wrap (#/.Primitive #/.Unit)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux new file mode 100644 index 000000000..9ce2b1faa --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux @@ -0,0 +1,85 @@ +(.module: + [library + [lux #* + [abstract + monad] + [control + ["." exception (#+ exception:)]] + ["." meta] + [data + ["." text ("#\." equivalence) + ["%" format (#+ format)]]]]] + ["." // #_ + ["#." scope] + ["#." type] + ["/#" // #_ + ["#." extension] + [// + ["/" analysis (#+ Analysis Operation)] + [/// + ["#." reference] + ["#" phase]]]]]) + +(exception: #export (foreign_module_has_not_been_imported {current Text} {foreign Text}) + (exception.report + ["Current" current] + ["Foreign" foreign])) + +(exception: #export (definition_has_not_been_exported {definition Name}) + (exception.report + ["Definition" (%.name definition)])) + +(def: (definition def_name) + (-> Name (Operation Analysis)) + (with_expansions [<return> (wrap (|> def_name ///reference.constant #/.Reference))] + (do {! ///.monad} + [constant (///extension.lift (meta.find_def def_name))] + (case constant + (#.Left real_def_name) + (definition real_def_name) + + (#.Right [exported? actualT def_anns _]) + (do ! + [_ (//type.infer actualT) + (^@ def_name [::module ::name]) (///extension.lift (meta.normalize def_name)) + current (///extension.lift meta.current_module_name)] + (if (text\= current ::module) + <return> + (if exported? + (do ! + [imported! (///extension.lift (meta.imported_by? ::module current))] + (if imported! + <return> + (/.throw foreign_module_has_not_been_imported [current ::module]))) + (/.throw definition_has_not_been_exported def_name)))))))) + +(def: (variable var_name) + (-> Text (Operation (Maybe Analysis))) + (do {! ///.monad} + [?var (//scope.find var_name)] + (case ?var + (#.Some [actualT ref]) + (do ! + [_ (//type.infer actualT)] + (wrap (#.Some (|> ref ///reference.variable #/.Reference)))) + + #.None + (wrap #.None)))) + +(def: #export (reference reference) + (-> Name (Operation Analysis)) + (case reference + ["" simple_name] + (do {! ///.monad} + [?var (variable simple_name)] + (case ?var + (#.Some varA) + (wrap varA) + + #.None + (do ! + [this_module (///extension.lift meta.current_module_name)] + (definition [this_module simple_name])))) + + _ + (definition reference))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/scope.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/scope.lux new file mode 100644 index 000000000..c0e598e06 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/scope.lux @@ -0,0 +1,206 @@ +(.module: + [library + [lux #* + [abstract + monad] + [control + ["." try] + ["." exception (#+ exception:)]] + [data + ["." text ("#\." equivalence)] + ["." maybe ("#\." monad)] + ["." product] + [collection + ["." list ("#\." functor fold monoid)] + [dictionary + ["." plist]]]]]] + ["." /// #_ + ["#." extension] + [// + ["/" analysis (#+ Operation Phase)] + [/// + [reference + ["." variable (#+ Register Variable)]] + ["#" phase]]]]) + +(type: Local (Bindings Text [Type Register])) +(type: Foreign (Bindings Text [Type Variable])) + +(def: (local? name scope) + (-> Text Scope Bit) + (|> scope + (get@ [#.locals #.mappings]) + (plist.contains? name))) + +(def: (local name scope) + (-> Text Scope (Maybe [Type Variable])) + (|> scope + (get@ [#.locals #.mappings]) + (plist.get name) + (maybe\map (function (_ [type value]) + [type (#variable.Local value)])))) + +(def: (captured? name scope) + (-> Text Scope Bit) + (|> scope + (get@ [#.captured #.mappings]) + (plist.contains? name))) + +(def: (captured name scope) + (-> Text Scope (Maybe [Type Variable])) + (loop [idx 0 + mappings (get@ [#.captured #.mappings] scope)] + (case mappings + (#.Cons [_name [_source_type _source_ref]] mappings') + (if (text\= name _name) + (#.Some [_source_type (#variable.Foreign idx)]) + (recur (inc idx) mappings')) + + #.Nil + #.None))) + +(def: (reference? name scope) + (-> Text Scope Bit) + (or (local? name scope) + (captured? name scope))) + +(def: (reference name scope) + (-> Text Scope (Maybe [Type Variable])) + (case (..local name scope) + (#.Some type) + (#.Some type) + + _ + (..captured name scope))) + +(def: #export (find name) + (-> Text (Operation (Maybe [Type Variable]))) + (///extension.lift + (function (_ state) + (let [[inner outer] (|> state + (get@ #.scopes) + (list.split_with (|>> (reference? name) not)))] + (case outer + #.Nil + (#.Right [state #.None]) + + (#.Cons top_outer _) + (let [[ref_type init_ref] (maybe.default (undefined) + (..reference name top_outer)) + [ref inner'] (list\fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)]) + (function (_ scope ref+inner) + [(#variable.Foreign (get@ [#.captured #.counter] scope)) + (#.Cons (update@ #.captured + (: (-> Foreign Foreign) + (|>> (update@ #.counter inc) + (update@ #.mappings (plist.put name [ref_type (product.left ref+inner)])))) + scope) + (product.right ref+inner))])) + [init_ref #.Nil] + (list.reverse inner)) + scopes (list\compose inner' outer)] + (#.Right [(set@ #.scopes scopes state) + (#.Some [ref_type ref])])) + ))))) + +(exception: #export cannot_create_local_binding_without_a_scope) +(exception: #export invalid_scope_alteration) + +(def: #export (with_local [name type] action) + (All [a] (-> [Text Type] (Operation a) (Operation a))) + (function (_ [bundle state]) + (case (get@ #.scopes state) + (#.Cons head tail) + (let [old_mappings (get@ [#.locals #.mappings] head) + new_var_id (get@ [#.locals #.counter] head) + new_head (update@ #.locals + (: (-> Local Local) + (|>> (update@ #.counter inc) + (update@ #.mappings (plist.put name [type new_var_id])))) + head)] + (case (///.run' [bundle (set@ #.scopes (#.Cons new_head tail) state)] + action) + (#try.Success [[bundle' state'] output]) + (case (get@ #.scopes state') + (#.Cons head' tail') + (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head') + tail')] + (#try.Success [[bundle' (set@ #.scopes scopes' state')] + output])) + + _ + (exception.throw ..invalid_scope_alteration [])) + + (#try.Failure error) + (#try.Failure error))) + + _ + (exception.throw ..cannot_create_local_binding_without_a_scope [])) + )) + +(template [<name> <val_type>] + [(def: <name> + (Bindings Text [Type <val_type>]) + {#.counter 0 + #.mappings (list)})] + + [init_locals Nat] + [init_captured Variable] + ) + +(def: (scope parent_name child_name) + (-> (List Text) Text Scope) + {#.name (list& child_name parent_name) + #.inner 0 + #.locals init_locals + #.captured init_captured}) + +(def: #export (with_scope name action) + (All [a] (-> Text (Operation a) (Operation a))) + (function (_ [bundle state]) + (let [parent_name (case (get@ #.scopes state) + #.Nil + (list) + + (#.Cons top _) + (get@ #.name top))] + (case (action [bundle (update@ #.scopes + (|>> (#.Cons (scope parent_name name))) + state)]) + (#try.Success [[bundle' state'] output]) + (#try.Success [[bundle' (update@ #.scopes + (|>> list.tail (maybe.default (list))) + state')] + output]) + + (#try.Failure error) + (#try.Failure error))) + )) + +(exception: #export cannot_get_next_reference_when_there_is_no_scope) + +(def: #export next_local + (Operation Register) + (///extension.lift + (function (_ state) + (case (get@ #.scopes state) + (#.Cons top _) + (#try.Success [state (get@ [#.locals #.counter] top)]) + + #.Nil + (exception.throw ..cannot_get_next_reference_when_there_is_no_scope []))))) + +(def: (ref_to_variable ref) + (-> Ref Variable) + (case ref + (#.Local register) + (#variable.Local register) + + (#.Captured register) + (#variable.Foreign register))) + +(def: #export (environment scope) + (-> Scope (List Variable)) + (|> scope + (get@ [#.captured #.mappings]) + (list\map (function (_ [_ [_ ref]]) (ref_to_variable ref))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux new file mode 100644 index 000000000..0f8106a7d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux @@ -0,0 +1,361 @@ +(.module: + [library + [lux #* + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["ex" exception (#+ exception:)] + ["." state]] + [data + ["." name] + ["." product] + ["." maybe] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)] + ["." dictionary (#+ Dictionary)]]] + [macro + ["." code]] + [math + [number + ["n" nat]]] + ["." type + ["." check]]]] + ["." // #_ + ["#." type] + ["#." primitive] + ["#." inference] + ["/#" // #_ + ["#." extension] + [// + ["/" analysis (#+ Tag Analysis Operation Phase)] + [/// + ["#" phase] + [meta + [archive (#+ Archive)]]]]]]) + +(exception: #export (invalid_variant_type {type Type} {tag Tag} {code Code}) + (ex.report ["Type" (%.type type)] + ["Tag" (%.nat tag)] + ["Expression" (%.code code)])) + +(template [<name>] + [(exception: #export (<name> {type Type} {members (List Code)}) + (ex.report ["Type" (%.type type)] + ["Expression" (%.code (` [(~+ members)]))]))] + + [invalid_tuple_type] + [cannot_analyse_tuple] + ) + +(exception: #export (not_a_quantified_type {type Type}) + (%.type type)) + +(template [<name>] + [(exception: #export (<name> {type Type} {tag Tag} {code Code}) + (ex.report ["Type" (%.type type)] + ["Tag" (%.nat tag)] + ["Expression" (%.code code)]))] + + [cannot_analyse_variant] + [cannot_infer_numeric_tag] + ) + +(exception: #export (record_keys_must_be_tags {key Code} {record (List [Code Code])}) + (ex.report ["Key" (%.code key)] + ["Record" (%.code (code.record record))])) + +(template [<name>] + [(exception: #export (<name> {key Name} {record (List [Name Code])}) + (ex.report ["Tag" (%.code (code.tag key))] + ["Record" (%.code (code.record (list\map (function (_ [keyI valC]) + [(code.tag keyI) valC]) + record)))]))] + + [cannot_repeat_tag] + ) + +(exception: #export (tag_does_not_belong_to_record {key Name} {type Type}) + (ex.report ["Tag" (%.code (code.tag key))] + ["Type" (%.type type)])) + +(exception: #export (record_size_mismatch {expected Nat} {actual Nat} {type Type} {record (List [Name Code])}) + (ex.report ["Expected" (%.nat expected)] + ["Actual" (%.nat actual)] + ["Type" (%.type type)] + ["Expression" (%.code (|> record + (list\map (function (_ [keyI valueC]) + [(code.tag keyI) valueC])) + code.record))])) + +(def: #export (sum analyse lefts right? archive) + (-> Phase Nat Bit Phase) + (let [tag (/.tag lefts right?)] + (function (recur valueC) + (do {! ///.monad} + [expectedT (///extension.lift meta.expected_type) + expectedT' (//type.with_env + (check.clean expectedT))] + (/.with_stack ..cannot_analyse_variant [expectedT' tag valueC] + (case expectedT + (#.Sum _) + (let [flat (type.flatten_variant expectedT)] + (case (list.nth tag flat) + (#.Some variant_type) + (do ! + [valueA (//type.with_type variant_type + (analyse archive valueC))] + (wrap (/.variant [lefts right? valueA]))) + + #.None + (/.throw //inference.variant_tag_out_of_bounds [(list.size flat) tag expectedT]))) + + (#.Named name unnamedT) + (//type.with_type unnamedT + (recur valueC)) + + (#.Var id) + (do ! + [?expectedT' (//type.with_env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (//type.with_type expectedT' + (recur valueC)) + + ## Cannot do inference when the tag is numeric. + ## This is because there is no way of knowing how many + ## cases the inferred sum type would have. + _ + (/.throw ..cannot_infer_numeric_tag [expectedT tag valueC]))) + + (^template [<tag> <instancer>] + [(<tag> _) + (do ! + [[instance_id instanceT] (//type.with_env <instancer>)] + (//type.with_type (maybe.assume (type.apply (list instanceT) expectedT)) + (recur valueC)))]) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT_id) + (do ! + [?funT' (//type.with_env (check.read funT_id))] + (case ?funT' + (#.Some funT') + (//type.with_type (#.Apply inputT funT') + (recur valueC)) + + _ + (/.throw ..invalid_variant_type [expectedT tag valueC]))) + + _ + (case (type.apply (list inputT) funT) + (#.Some outputT) + (//type.with_type outputT + (recur valueC)) + + #.None + (/.throw ..not_a_quantified_type funT))) + + _ + (/.throw ..invalid_variant_type [expectedT tag valueC]))))))) + +(def: (typed_product archive analyse members) + (-> Archive Phase (List Code) (Operation Analysis)) + (do {! ///.monad} + [expectedT (///extension.lift meta.expected_type) + membersA+ (: (Operation (List Analysis)) + (loop [membersT+ (type.flatten_tuple expectedT) + membersC+ members] + (case [membersT+ membersC+] + [(#.Cons memberT #.Nil) _] + (//type.with_type memberT + (\ ! map (|>> list) (analyse archive (code.tuple membersC+)))) + + [_ (#.Cons memberC #.Nil)] + (//type.with_type (type.tuple membersT+) + (\ ! map (|>> list) (analyse archive memberC))) + + [(#.Cons memberT membersT+') (#.Cons memberC membersC+')] + (do ! + [memberA (//type.with_type memberT + (analyse archive memberC)) + memberA+ (recur membersT+' membersC+')] + (wrap (#.Cons memberA memberA+))) + + _ + (/.throw ..cannot_analyse_tuple [expectedT members]))))] + (wrap (/.tuple membersA+)))) + +(def: #export (product archive analyse membersC) + (-> Archive Phase (List Code) (Operation Analysis)) + (do {! ///.monad} + [expectedT (///extension.lift meta.expected_type)] + (/.with_stack ..cannot_analyse_tuple [expectedT membersC] + (case expectedT + (#.Product _) + (..typed_product archive analyse membersC) + + (#.Named name unnamedT) + (//type.with_type unnamedT + (product archive analyse membersC)) + + (#.Var id) + (do ! + [?expectedT' (//type.with_env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (//type.with_type expectedT' + (product archive analyse membersC)) + + _ + ## Must do inference... + (do ! + [membersTA (monad.map ! (|>> (analyse archive) //type.with_inference) + membersC) + _ (//type.with_env + (check.check expectedT + (type.tuple (list\map product.left membersTA))))] + (wrap (/.tuple (list\map product.right membersTA)))))) + + (^template [<tag> <instancer>] + [(<tag> _) + (do ! + [[instance_id instanceT] (//type.with_env <instancer>)] + (//type.with_type (maybe.assume (type.apply (list instanceT) expectedT)) + (product archive analyse membersC)))]) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT_id) + (do ! + [?funT' (//type.with_env (check.read funT_id))] + (case ?funT' + (#.Some funT') + (//type.with_type (#.Apply inputT funT') + (product archive analyse membersC)) + + _ + (/.throw ..invalid_tuple_type [expectedT membersC]))) + + _ + (case (type.apply (list inputT) funT) + (#.Some outputT) + (//type.with_type outputT + (product archive analyse membersC)) + + #.None + (/.throw ..not_a_quantified_type funT))) + + _ + (/.throw ..invalid_tuple_type [expectedT membersC]) + )))) + +(def: #export (tagged_sum analyse tag archive valueC) + (-> Phase Name Phase) + (do {! ///.monad} + [tag (///extension.lift (meta.normalize tag)) + [idx group variantT] (///extension.lift (meta.resolve_tag tag)) + #let [case_size (list.size group) + [lefts right?] (/.choice case_size idx)] + expectedT (///extension.lift meta.expected_type)] + (case expectedT + (#.Var _) + (do ! + [inferenceT (//inference.variant idx case_size variantT) + [inferredT valueA+] (//inference.general archive analyse inferenceT (list valueC))] + (wrap (/.variant [lefts right? (|> valueA+ list.head maybe.assume)]))) + + _ + (..sum analyse lefts right? archive valueC)))) + +## There cannot be any ambiguity or improper syntax when analysing +## records, so they must be normalized for further analysis. +## Normalization just means that all the tags get resolved to their +## canonical form (with their corresponding module identified). +(def: #export (normalize record) + (-> (List [Code Code]) (Operation (List [Name Code]))) + (monad.map ///.monad + (function (_ [key val]) + (case key + [_ (#.Tag key)] + (do ///.monad + [key (///extension.lift (meta.normalize key))] + (wrap [key val])) + + _ + (/.throw ..record_keys_must_be_tags [key record]))) + record)) + +## Lux already possesses the means to analyse tuples, so +## re-implementing the same functionality for records makes no sense. +## Records, thus, get transformed into tuples by ordering the elements. +(def: #export (order record) + (-> (List [Name Code]) (Operation [(List Code) Type])) + (case record + ## empty_record = empty_tuple = unit = [] + #.Nil + (\ ///.monad wrap [(list) Any]) + + (#.Cons [head_k head_v] _) + (do {! ///.monad} + [head_k (///extension.lift (meta.normalize head_k)) + [_ tag_set recordT] (///extension.lift (meta.resolve_tag head_k)) + #let [size_record (list.size record) + size_ts (list.size tag_set)] + _ (if (n.= size_ts size_record) + (wrap []) + (/.throw ..record_size_mismatch [size_ts size_record recordT record])) + #let [tuple_range (list.indices size_ts) + tag->idx (dictionary.from_list name.hash (list.zip/2 tag_set tuple_range))] + idx->val (monad.fold ! + (function (_ [key val] idx->val) + (do ! + [key (///extension.lift (meta.normalize key))] + (case (dictionary.get key tag->idx) + (#.Some idx) + (if (dictionary.key? idx->val idx) + (/.throw ..cannot_repeat_tag [key record]) + (wrap (dictionary.put idx val idx->val))) + + #.None + (/.throw ..tag_does_not_belong_to_record [key recordT])))) + (: (Dictionary Nat Code) + (dictionary.new n.hash)) + record) + #let [ordered_tuple (list\map (function (_ idx) (maybe.assume (dictionary.get idx idx->val))) + tuple_range)]] + (wrap [ordered_tuple recordT])) + )) + +(def: #export (record archive analyse members) + (-> Archive Phase (List [Code Code]) (Operation Analysis)) + (case members + (^ (list)) + //primitive.unit + + (^ (list [_ singletonC])) + (analyse archive singletonC) + + _ + (do {! ///.monad} + [members (normalize members) + [membersC recordT] (order members) + expectedT (///extension.lift meta.expected_type)] + (case expectedT + (#.Var _) + (do ! + [inferenceT (//inference.record recordT) + [inferredT membersA] (//inference.general archive analyse inferenceT membersC)] + (wrap (/.tuple membersA))) + + _ + (..product archive analyse membersC))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/type.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/type.lux new file mode 100644 index 000000000..61948e7c2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/type.lux @@ -0,0 +1,56 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." function] + ["." try]] + [type + ["." check (#+ Check)]] + ["." meta]]] + ["." /// #_ + ["#." extension] + [// + ["/" analysis (#+ Operation)] + [/// + ["#" phase]]]]) + +(def: #export (with_type expected) + (All [a] (-> Type (Operation a) (Operation a))) + (///extension.localized (get@ #.expected) (set@ #.expected) + (function.constant (#.Some expected)))) + +(def: #export (with_env action) + (All [a] (-> (Check a) (Operation a))) + (function (_ (^@ stateE [bundle state])) + (case (action (get@ #.type_context state)) + (#try.Success [context' output]) + (#try.Success [[bundle (set@ #.type_context context' state)] + output]) + + (#try.Failure error) + ((/.fail error) stateE)))) + +(def: #export with_fresh_env + (All [a] (-> (Operation a) (Operation a))) + (///extension.localized (get@ #.type_context) (set@ #.type_context) + (function.constant check.fresh_context))) + +(def: #export (infer actualT) + (-> Type (Operation Any)) + (do ///.monad + [expectedT (///extension.lift meta.expected_type)] + (with_env + (check.check expectedT actualT)))) + +(def: #export (with_inference action) + (All [a] (-> (Operation a) (Operation [Type a]))) + (do ///.monad + [[_ varT] (..with_env + check.var) + output (with_type varT + action) + knownT (..with_env + (check.clean varT))] + (wrap [knownT output]))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/directive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/directive.lux new file mode 100644 index 000000000..882ac3a6e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/directive.lux @@ -0,0 +1,79 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." exception (#+ exception:)]] + [data + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." fold monoid)]]] + ["." meta]]] + ["." // #_ + ["#." extension] + ["#." analysis + ["#/." type]] + ["/#" // #_ + ["/" directive (#+ Phase)] + ["#." analysis + ["#/." macro (#+ Expander)]] + [/// + ["//" phase] + [reference (#+) + [variable (#+)]]]]]) + +(exception: #export (not_a_directive {code Code}) + (exception.report + ["Directive" (%.code code)])) + +(exception: #export (invalid_macro_call {code Code}) + (exception.report + ["Code" (%.code code)])) + +(exception: #export (macro_was_not_found {name Name}) + (exception.report + ["Name" (%.name name)])) + +(with_expansions [<lux_def_module> (as_is [|form_location| (#.Form (list& [|text_location| (#.Text "lux def module")] annotations))])] + (def: #export (phase expander) + (-> Expander Phase) + (let [analyze (//analysis.phase expander)] + (function (recur archive code) + (case code + (^ [_ (#.Form (list& [_ (#.Text name)] inputs))]) + (//extension.apply archive recur [name inputs]) + + (^ [_ (#.Form (list& macro inputs))]) + (do {! //.monad} + [expansion (/.lift_analysis + (do ! + [macroA (//analysis/type.with_type Macro + (analyze archive macro))] + (case macroA + (^ (///analysis.constant macro_name)) + (do ! + [?macro (//extension.lift (meta.find_macro macro_name)) + macro (case ?macro + (#.Some macro) + (wrap macro) + + #.None + (//.throw ..macro_was_not_found macro_name))] + (//extension.lift (///analysis/macro.expand expander macro_name macro inputs))) + + _ + (//.throw ..invalid_macro_call code))))] + (case expansion + (^ (list& <lux_def_module> referrals)) + (|> (recur archive <lux_def_module>) + (\ ! map (update@ #/.referrals (list\compose referrals)))) + + _ + (|> expansion + (monad.map ! (recur archive)) + (\ ! map (list\fold /.merge_requirements /.no_requirements))))) + + _ + (//.throw ..not_a_directive code)))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension.lux new file mode 100644 index 000000000..fd30c45d2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension.lux @@ -0,0 +1,177 @@ +(.module: + [library + [lux (#- Name) + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + ["." monad (#+ do)]] + [control + ["." function] + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." text ("#\." order) + ["%" format (#+ Format format)]] + [collection + ["." list] + ["." dictionary (#+ Dictionary)]]]]] + [///// + ["//" phase] + [meta + [archive (#+ Archive)]]]) + +(type: #export Name + Text) + +(type: #export (Extension a) + [Name (List a)]) + +(def: #export equivalence + (All [a] (-> (Equivalence a) (Equivalence (Extension a)))) + (|>> list.equivalence + (product.equivalence text.equivalence))) + +(def: #export hash + (All [a] (-> (Hash a) (Hash (Extension a)))) + (|>> list.hash + (product.hash text.hash))) + +(with_expansions [<Bundle> (as_is (Dictionary Name (Handler s i o)))] + (type: #export (Handler s i o) + (-> Name + (//.Phase [<Bundle> s] i o) + (//.Phase [<Bundle> s] (List i) o))) + + (type: #export (Bundle s i o) + <Bundle>)) + +(def: #export empty + Bundle + (dictionary.new text.hash)) + +(type: #export (State s i o) + {#bundle (Bundle s i o) + #state s}) + +(type: #export (Operation s i o v) + (//.Operation (State s i o) v)) + +(type: #export (Phase s i o) + (//.Phase (State s i o) i o)) + +(exception: #export (cannot_overwrite {name Name}) + (exception.report + ["Extension" (%.text name)])) + +(exception: #export (incorrect_arity {name Name} {arity Nat} {args Nat}) + (exception.report + ["Extension" (%.text name)] + ["Expected" (%.nat arity)] + ["Actual" (%.nat args)])) + +(exception: #export [a] (invalid_syntax {name Name} {%format (Format a)} {inputs (List a)}) + (exception.report + ["Extension" (%.text name)] + ["Inputs" (exception.enumerate %format inputs)])) + +(exception: #export [s i o] (unknown {name Name} {bundle (Bundle s i o)}) + (exception.report + ["Extension" (%.text name)] + ["Available" (|> bundle + dictionary.keys + (list.sort text\<) + (exception.enumerate %.text))])) + +(type: #export (Extender s i o) + (-> Any (Handler s i o))) + +(def: #export (install extender name handler) + (All [s i o] + (-> (Extender s i o) Text (Handler s i o) (Operation s i o Any))) + (function (_ [bundle state]) + (case (dictionary.get name bundle) + #.None + (#try.Success [[(dictionary.put name (extender handler) bundle) state] + []]) + + _ + (exception.throw ..cannot_overwrite name)))) + +(def: #export (with extender extensions) + (All [s i o] + (-> Extender (Bundle s i o) (Operation s i o Any))) + (|> extensions + dictionary.entries + (monad.fold //.monad + (function (_ [extension handle] output) + (..install extender extension handle)) + []))) + +(def: #export (apply archive phase [name parameters]) + (All [s i o] + (-> Archive (Phase s i o) (Extension i) (Operation s i o o))) + (function (_ (^@ stateE [bundle state])) + (case (dictionary.get name bundle) + (#.Some handler) + (((handler name phase) archive parameters) + stateE) + + #.None + (exception.throw ..unknown [name bundle])))) + +(def: #export (localized get set transform) + (All [s s' i o v] + (-> (-> s s') (-> s' s s) (-> s' s') + (-> (Operation s i o v) (Operation s i o v)))) + (function (_ operation) + (function (_ [bundle state]) + (let [old (get state)] + (case (operation [bundle (set (transform old) state)]) + (#try.Success [[bundle' state'] output]) + (#try.Success [[bundle' (set old state')] output]) + + (#try.Failure error) + (#try.Failure error)))))) + +(def: #export (temporary transform) + (All [s i o v] + (-> (-> s s) + (-> (Operation s i o v) (Operation s i o v)))) + (function (_ operation) + (function (_ [bundle state]) + (case (operation [bundle (transform state)]) + (#try.Success [[bundle' state'] output]) + (#try.Success [[bundle' state] output]) + + (#try.Failure error) + (#try.Failure error))))) + +(def: #export (with_state state) + (All [s i o v] + (-> s (-> (Operation s i o v) (Operation s i o v)))) + (..temporary (function.constant state))) + +(def: #export (read get) + (All [s i o v] + (-> (-> s v) (Operation s i o v))) + (function (_ [bundle state]) + (#try.Success [[bundle state] (get state)]))) + +(def: #export (update transform) + (All [s i o] + (-> (-> s s) (Operation s i o Any))) + (function (_ [bundle state]) + (#try.Success [[bundle (transform state)] []]))) + +(def: #export (lift action) + (All [s i o v] + (-> (//.Operation s v) + (//.Operation [(Bundle s i o) s] v))) + (function (_ [bundle state]) + (case (action state) + (#try.Success [state' output]) + (#try.Success [[bundle state'] output]) + + (#try.Failure error) + (#try.Failure error)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis.lux new file mode 100644 index 000000000..a1a979555 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis.lux @@ -0,0 +1,16 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + [//// + [analysis (#+ Bundle) + [evaluation (#+ Eval)]]] + ["." / #_ + ["#." lux]]) + +(def: #export (bundle eval host-specific) + (-> Eval Bundle Bundle) + (dictionary.merge host-specific + (/lux.bundle eval))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux new file mode 100644 index 000000000..348124448 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux @@ -0,0 +1,35 @@ +(.module: + [library + [lux #* + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]]] + [data + [collection + ["." array (#+ Array)] + ["." dictionary] + ["." list]]] + ["." type + ["." check]] + ["@" target + ["_" common_lisp]]]] + [// + ["/" lux (#+ custom)] + [// + ["." bundle] + [// + ["." analysis #_ + ["#/." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) + +(def: #export bundle + Bundle + (<| (bundle.prefix "common_lisp") + (|> bundle.empty + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux new file mode 100644 index 000000000..5660a2a85 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux @@ -0,0 +1,218 @@ +(.module: + [library + [lux #* + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]]] + [data + [collection + ["." array (#+ Array)] + ["." dictionary] + ["." list]]] + ["." type + ["." check]] + ["@" target + ["_" js]]]] + [// + ["/" lux (#+ custom)] + [// + ["." bundle] + [// + ["." analysis #_ + ["#/." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) + +(def: array::new + Handler + (custom + [<c>.any + (function (_ extension phase archive lengthC) + (do phase.monad + [lengthA (analysis/type.with_type Nat + (phase archive lengthC)) + [var_id varT] (analysis/type.with_env check.var) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list lengthA)))))])) + +(def: array::length + Handler + (custom + [<c>.any + (function (_ extension phase archive arrayC) + (do phase.monad + [[var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer Nat)] + (wrap (#analysis.Extension extension (list arrayA)))))])) + +(def: array::read + Handler + (custom + [(<>.and <c>.any <c>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer varT)] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: array::write + Handler + (custom + [($_ <>.and <c>.any <c>.any <c>.any) + (function (_ extension phase archive [indexC valueC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + valueA (analysis/type.with_type varT + (phase archive valueC)) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) + +(def: array::delete + Handler + (custom + [($_ <>.and <c>.any <c>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) + ))) + +(def: object::new + Handler + (custom + [($_ <>.and <c>.any (<c>.tuple (<>.some <c>.any))) + (function (_ extension phase archive [constructorC inputsC]) + (do {! phase.monad} + [constructorA (analysis/type.with_type Any + (phase archive constructorC)) + inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list& constructorA inputsA)))))])) + +(def: object::get + Handler + (custom + [($_ <>.and <c>.text <c>.any) + (function (_ extension phase archive [fieldC objectC]) + (do phase.monad + [objectA (analysis/type.with_type Any + (phase archive objectC)) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list (analysis.text fieldC) + objectA)))))])) + +(def: object::do + Handler + (custom + [($_ <>.and <c>.text <c>.any (<c>.tuple (<>.some <c>.any))) + (function (_ extension phase archive [methodC objectC inputsC]) + (do {! phase.monad} + [objectA (analysis/type.with_type Any + (phase archive objectC)) + inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list& (analysis.text methodC) + objectA + inputsA)))))])) + +(def: bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "new" object::new) + (bundle.install "get" object::get) + (bundle.install "do" object::do) + (bundle.install "null" (/.nullary Any)) + (bundle.install "null?" (/.unary Any Bit)) + (bundle.install "undefined" (/.nullary Any)) + (bundle.install "undefined?" (/.unary Any Bit)) + ))) + +(def: js::constant + Handler + (custom + [<c>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list (analysis.text name))))))])) + +(def: js::apply + Handler + (custom + [($_ <>.and <c>.any (<>.some <c>.any)) + (function (_ extension phase archive [abstractionC inputsC]) + (do {! phase.monad} + [abstractionA (analysis/type.with_type Any + (phase archive abstractionC)) + inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) + +(def: js::type_of + Handler + (custom + [<c>.any + (function (_ extension phase archive objectC) + (do phase.monad + [objectA (analysis/type.with_type Any + (phase archive objectC)) + _ (analysis/type.infer .Text)] + (wrap (#analysis.Extension extension (list objectA)))))])) + +(def: js::function + Handler + (custom + [($_ <>.and <c>.nat <c>.any) + (function (_ extension phase archive [arity abstractionC]) + (do phase.monad + [#let [inputT (type.tuple (list.repeat arity Any))] + abstractionA (analysis/type.with_type (-> inputT Any) + (phase archive abstractionC)) + _ (analysis/type.infer (for {@.js ffi.Function} + Any))] + (wrap (#analysis.Extension extension (list (analysis.nat arity) + abstractionA)))))])) + +(def: #export bundle + Bundle + (<| (bundle.prefix "js") + (|> bundle.empty + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + + (bundle.install "constant" js::constant) + (bundle.install "apply" js::apply) + (bundle.install "type-of" js::type_of) + (bundle.install "function" js::function) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux new file mode 100644 index 000000000..76bcd528e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -0,0 +1,2076 @@ +(.module: + [library + [lux (#- Type Module primitive type char int) + ["." ffi (#+ import:)] + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + pipe + ["." try (#+ Try) ("#\." monad)] + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" code (#+ Parser)] + ["<.>" text]]] + [data + ["." maybe] + ["." product] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." list ("#\." fold monad monoid)] + ["." array] + ["." dictionary (#+ Dictionary)]]] + [math + [number + ["n" nat]]] + [target + ["." jvm #_ + [".!" reflection] + [encoding + [name (#+ External)]] + ["#" type (#+ Type Argument Typed) ("#\." equivalence) + ["." category (#+ Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method)] + ["." box] + ["." reflection] + ["." descriptor] + ["." signature] + ["#_." parser] + ["#_." alias (#+ Aliasing)] + [".T" lux (#+ Mapping)]]]] + ["." type + ["." check (#+ Check) ("#\." monad)]]]] + ["." // #_ + ["#." lux (#+ custom)] + ["/#" // + ["#." bundle] + ["/#" // #_ + [analysis + [".A" type] + [".A" inference] + ["." scope]] + ["/#" // #_ + ["#." analysis (#+ Analysis Operation Phase Handler Bundle)] + ["#." synthesis] + [/// + ["." phase ("#\." monad)] + [meta + [archive (#+ Archive) + [descriptor (#+ Module)]]]]]]]]) + +(import: java/lang/Object + ["#::." + (equals [java/lang/Object] boolean)]) + +(import: java/lang/reflect/Type) + +(import: (java/lang/reflect/TypeVariable d) + ["#::." + (getName [] java/lang/String) + (getBounds [] [java/lang/reflect/Type])]) + +(import: java/lang/reflect/Modifier + ["#::." + (#static isStatic [int] boolean) + (#static isFinal [int] boolean) + (#static isInterface [int] boolean) + (#static isAbstract [int] boolean)]) + +(import: java/lang/annotation/Annotation) + +(import: java/lang/reflect/Method + ["#::." + (getName [] java/lang/String) + (getModifiers [] int) + (getDeclaringClass [] (java/lang/Class java/lang/Object)) + (getTypeParameters [] [(java/lang/reflect/TypeVariable java/lang/reflect/Method)]) + (getGenericParameterTypes [] [java/lang/reflect/Type]) + (getGenericReturnType [] java/lang/reflect/Type) + (getGenericExceptionTypes [] [java/lang/reflect/Type]) + (getDeclaredAnnotations [] [java/lang/annotation/Annotation])]) + +(import: (java/lang/reflect/Constructor c) + ["#::." + (getModifiers [] int) + (getDeclaringClass [] (java/lang/Class c)) + (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/reflect/Constructor c))]) + (getGenericParameterTypes [] [java/lang/reflect/Type]) + (getGenericExceptionTypes [] [java/lang/reflect/Type]) + (getDeclaredAnnotations [] [java/lang/annotation/Annotation])]) + +(import: (java/lang/Class c) + ["#::." + (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object)) + (getName [] java/lang/String) + (getModifiers [] int) + (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean) + (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/Class c))]) + (getGenericInterfaces [] [java/lang/reflect/Type]) + (getGenericSuperclass [] #? java/lang/reflect/Type) + (getDeclaredField [java/lang/String] #try java/lang/reflect/Field) + (getConstructors [] [(java/lang/reflect/Constructor java/lang/Object)]) + (getDeclaredMethods [] [java/lang/reflect/Method]) + (getDeclaredAnnotations [] [java/lang/annotation/Annotation])]) + +(template [<name>] + [(exception: #export (<name> {class External} {field Text}) + (exception.report + ["Class" (%.text class)] + ["Field" (%.text field)]))] + + [cannot_set_a_final_field] + [deprecated_field] + ) + +(exception: #export (deprecated_method {class External} {method Text} {type .Type}) + (exception.report + ["Class" (%.text class)] + ["Method" (%.text method)] + ["Type" (%.type type)])) + +(exception: #export (deprecated_class {class External}) + (exception.report + ["Class" (%.text class)])) + +(def: (ensure_fresh_class! name) + (-> External (Operation Any)) + (do phase.monad + [class (phase.lift (reflection!.load name))] + (phase.assert ..deprecated_class [name] + (|> class + java/lang/Class::getDeclaredAnnotations + reflection!.deprecated? + not)))) + +(def: reflection + (All [category] + (-> (Type (<| Return' Value' category)) Text)) + (|>> jvm.reflection reflection.reflection)) + +(def: signature (|>> jvm.signature signature.signature)) + +(def: object_class + External + "java.lang.Object") + +(def: inheritance_relationship_type_name "_jvm_inheritance") +(def: #export (inheritance_relationship_type class super_class super_interfaces) + (-> .Type .Type (List .Type) .Type) + (#.Primitive ..inheritance_relationship_type_name + (list& class super_class super_interfaces))) + +## TODO: Get rid of this template block and use the definition in +## lux/ffi.jvm.lux ASAP +(template [<name> <class>] + [(def: #export <name> .Type (#.Primitive <class> #.Nil))] + + ## Boxes + [Boolean box.boolean] + [Byte box.byte] + [Short box.short] + [Integer box.int] + [Long box.long] + [Float box.float] + [Double box.double] + [Character box.char] + [String "java.lang.String"] + + ## Primitives + [boolean (reflection.reflection reflection.boolean)] + [byte (reflection.reflection reflection.byte)] + [short (reflection.reflection reflection.short)] + [int (reflection.reflection reflection.int)] + [long (reflection.reflection reflection.long)] + [float (reflection.reflection reflection.float)] + [double (reflection.reflection reflection.double)] + [char (reflection.reflection reflection.char)] + ) + +(type: Member + {#class External + #member Text}) + +(def: member + (Parser Member) + ($_ <>.and <code>.text <code>.text)) + +(type: Method_Signature + {#method .Type + #deprecated? Bit + #exceptions (List .Type)}) + +(template [<name>] + [(exception: #export (<name> {type .Type}) + (exception.report + ["Type" (%.type type)]))] + + [non_object] + [non_array] + [non_parameter] + [non_jvm_type] + ) + +(template [<name>] + [(exception: #export (<name> {class External}) + (exception.report + ["Class/type" (%.text class)]))] + + [non_interface] + [non_throwable] + [primitives_are_not_objects] + ) + +(template [<name>] + [(exception: #export (<name> {class External} + {method Text} + {inputsJT (List (Type Value))} + {hints (List Method_Signature)}) + (exception.report + ["Class" class] + ["Method" method] + ["Arguments" (exception.enumerate ..signature inputsJT)] + ["Hints" (exception.enumerate %.type (list\map product.left hints))]))] + + [no_candidates] + [too_many_candidates] + ) + +(exception: #export (cannot_cast {from .Type} {to .Type} {value Code}) + (exception.report + ["From" (%.type from)] + ["To" (%.type to)] + ["Value" (%.code value)])) + +(template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [primitives_cannot_have_type_parameters] + + [cannot_possibly_be_an_instance] + + [unknown_type_var] + ) + +(def: bundle::conversion + Bundle + (<| (///bundle.prefix "conversion") + (|> ///bundle.empty + (///bundle.install "double-to-float" (//lux.unary ..double ..float)) + (///bundle.install "double-to-int" (//lux.unary ..double ..int)) + (///bundle.install "double-to-long" (//lux.unary ..double ..long)) + (///bundle.install "float-to-double" (//lux.unary ..float ..double)) + (///bundle.install "float-to-int" (//lux.unary ..float ..int)) + (///bundle.install "float-to-long" (//lux.unary ..float ..long)) + (///bundle.install "int-to-byte" (//lux.unary ..int ..byte)) + (///bundle.install "int-to-char" (//lux.unary ..int ..char)) + (///bundle.install "int-to-double" (//lux.unary ..int ..double)) + (///bundle.install "int-to-float" (//lux.unary ..int ..float)) + (///bundle.install "int-to-long" (//lux.unary ..int ..long)) + (///bundle.install "int-to-short" (//lux.unary ..int ..short)) + (///bundle.install "long-to-double" (//lux.unary ..long ..double)) + (///bundle.install "long-to-float" (//lux.unary ..long ..float)) + (///bundle.install "long-to-int" (//lux.unary ..long ..int)) + (///bundle.install "long-to-short" (//lux.unary ..long ..short)) + (///bundle.install "long-to-byte" (//lux.unary ..long ..byte)) + (///bundle.install "char-to-byte" (//lux.unary ..char ..byte)) + (///bundle.install "char-to-short" (//lux.unary ..char ..short)) + (///bundle.install "char-to-int" (//lux.unary ..char ..int)) + (///bundle.install "char-to-long" (//lux.unary ..char ..long)) + (///bundle.install "byte-to-long" (//lux.unary ..byte ..long)) + (///bundle.install "short-to-long" (//lux.unary ..short ..long)) + ))) + +(template [<name> <prefix> <type>] + [(def: <name> + Bundle + (<| (///bundle.prefix (reflection.reflection <prefix>)) + (|> ///bundle.empty + (///bundle.install "+" (//lux.binary <type> <type> <type>)) + (///bundle.install "-" (//lux.binary <type> <type> <type>)) + (///bundle.install "*" (//lux.binary <type> <type> <type>)) + (///bundle.install "/" (//lux.binary <type> <type> <type>)) + (///bundle.install "%" (//lux.binary <type> <type> <type>)) + (///bundle.install "=" (//lux.binary <type> <type> Bit)) + (///bundle.install "<" (//lux.binary <type> <type> Bit)) + (///bundle.install "and" (//lux.binary <type> <type> <type>)) + (///bundle.install "or" (//lux.binary <type> <type> <type>)) + (///bundle.install "xor" (//lux.binary <type> <type> <type>)) + (///bundle.install "shl" (//lux.binary ..int <type> <type>)) + (///bundle.install "shr" (//lux.binary ..int <type> <type>)) + (///bundle.install "ushr" (//lux.binary ..int <type> <type>)) + )))] + + [bundle::int reflection.int ..int] + [bundle::long reflection.long ..long] + ) + +(template [<name> <prefix> <type>] + [(def: <name> + Bundle + (<| (///bundle.prefix (reflection.reflection <prefix>)) + (|> ///bundle.empty + (///bundle.install "+" (//lux.binary <type> <type> <type>)) + (///bundle.install "-" (//lux.binary <type> <type> <type>)) + (///bundle.install "*" (//lux.binary <type> <type> <type>)) + (///bundle.install "/" (//lux.binary <type> <type> <type>)) + (///bundle.install "%" (//lux.binary <type> <type> <type>)) + (///bundle.install "=" (//lux.binary <type> <type> Bit)) + (///bundle.install "<" (//lux.binary <type> <type> Bit)) + )))] + + [bundle::float reflection.float ..float] + [bundle::double reflection.double ..double] + ) + +(def: bundle::char + Bundle + (<| (///bundle.prefix (reflection.reflection reflection.char)) + (|> ///bundle.empty + (///bundle.install "=" (//lux.binary ..char ..char Bit)) + (///bundle.install "<" (//lux.binary ..char ..char Bit)) + ))) + +(def: #export boxes + (Dictionary External [External (Type Primitive)]) + (|> (list [(reflection.reflection reflection.boolean) [box.boolean jvm.boolean]] + [(reflection.reflection reflection.byte) [box.byte jvm.byte]] + [(reflection.reflection reflection.short) [box.short jvm.short]] + [(reflection.reflection reflection.int) [box.int jvm.int]] + [(reflection.reflection reflection.long) [box.long jvm.long]] + [(reflection.reflection reflection.float) [box.float jvm.float]] + [(reflection.reflection reflection.double) [box.double jvm.double]] + [(reflection.reflection reflection.char) [box.char jvm.char]]) + (dictionary.from_list text.hash))) + +(def: (jvm_type luxT) + (-> .Type (Operation (Type Value))) + (case luxT + (#.Named name anonymousT) + (jvm_type anonymousT) + + (#.Apply inputT abstractionT) + (case (type.apply (list inputT) abstractionT) + (#.Some outputT) + (jvm_type outputT) + + #.None + (/////analysis.throw ..non_jvm_type luxT)) + + (^ (#.Primitive (static array.type_name) (list elemT))) + (phase\map jvm.array (jvm_type elemT)) + + (#.Primitive class parametersT) + (case (dictionary.get class ..boxes) + (#.Some [_ primitive_type]) + (case parametersT + #.Nil + (phase\wrap primitive_type) + + _ + (/////analysis.throw ..primitives_cannot_have_type_parameters class)) + + #.None + (do {! phase.monad} + [parametersJT (: (Operation (List (Type Parameter))) + (monad.map ! + (function (_ parameterT) + (do phase.monad + [parameterJT (jvm_type parameterT)] + (case (jvm_parser.parameter? parameterJT) + (#.Some parameterJT) + (wrap parameterJT) + + #.None + (/////analysis.throw ..non_parameter parameterT)))) + parametersT))] + (wrap (jvm.class class parametersJT)))) + + (#.Ex _) + (phase\wrap (jvm.class ..object_class (list))) + + _ + (/////analysis.throw ..non_jvm_type luxT))) + +(def: (jvm_array_type objectT) + (-> .Type (Operation (Type Array))) + (do phase.monad + [objectJ (jvm_type objectT)] + (|> objectJ + ..signature + (<text>.run jvm_parser.array) + phase.lift))) + +(def: (primitive_array_length_handler primitive_type) + (-> (Type Primitive) Handler) + (function (_ extension_name analyse archive args) + (case args + (^ (list arrayC)) + (do phase.monad + [_ (typeA.infer ..int) + arrayA (typeA.with_type (#.Primitive (|> (jvm.array primitive_type) + ..reflection) + (list)) + (analyse archive arrayC))] + (wrap (#/////analysis.Extension extension_name (list arrayA)))) + + _ + (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def: array::length::object + Handler + (function (_ extension_name analyse archive args) + (case args + (^ (list arrayC)) + (do phase.monad + [_ (typeA.infer ..int) + [var_id varT] (typeA.with_env check.var) + arrayA (typeA.with_type (.type (array.Array varT)) + (analyse archive arrayC)) + varT (typeA.with_env (check.clean varT)) + arrayJT (jvm_array_type (.type (array.Array varT)))] + (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT)) + arrayA)))) + + _ + (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def: (new_primitive_array_handler primitive_type) + (-> (Type Primitive) Handler) + (function (_ extension_name analyse archive args) + (case args + (^ (list lengthC)) + (do phase.monad + [lengthA (typeA.with_type ..int + (analyse archive lengthC)) + _ (typeA.infer (#.Primitive (|> (jvm.array primitive_type) ..reflection) + (list)))] + (wrap (#/////analysis.Extension extension_name (list lengthA)))) + + _ + (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def: array::new::object + Handler + (function (_ extension_name analyse archive args) + (case args + (^ (list lengthC)) + (do phase.monad + [lengthA (typeA.with_type ..int + (analyse archive lengthC)) + expectedT (///.lift meta.expected_type) + expectedJT (jvm_array_type expectedT) + elementJT (case (jvm_parser.array? expectedJT) + (#.Some elementJT) + (wrap elementJT) + + #.None + (/////analysis.throw ..non_array expectedT))] + (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature elementJT)) + lengthA)))) + + _ + (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def: (check_parameter objectT) + (-> .Type (Operation (Type Parameter))) + (case objectT + (^ (#.Primitive (static array.type_name) + (list elementT))) + (/////analysis.throw ..non_parameter objectT) + + (#.Primitive name parameters) + (`` (cond (or (~~ (template [<type>] + [(text\= (..reflection <type>) name)] + + [jvm.boolean] + [jvm.byte] + [jvm.short] + [jvm.int] + [jvm.long] + [jvm.float] + [jvm.double] + [jvm.char])) + (text.starts_with? descriptor.array_prefix name)) + (/////analysis.throw ..non_parameter objectT) + + ## else + (phase\wrap (jvm.class name (list))))) + + (#.Named name anonymous) + (check_parameter anonymous) + + (^template [<tag>] + [(<tag> id) + (phase\wrap (jvm.class ..object_class (list)))]) + ([#.Var] + [#.Ex]) + + (^template [<tag>] + [(<tag> env unquantified) + (check_parameter unquantified)]) + ([#.UnivQ] + [#.ExQ]) + + (#.Apply inputT abstractionT) + (case (type.apply (list inputT) abstractionT) + (#.Some outputT) + (check_parameter outputT) + + #.None + (/////analysis.throw ..non_parameter objectT)) + + _ + (/////analysis.throw ..non_parameter objectT))) + +(def: (check_jvm objectT) + (-> .Type (Operation (Type Value))) + (case objectT + (#.Primitive name #.Nil) + (`` (cond (~~ (template [<type>] + [(text\= (..reflection <type>) name) + (phase\wrap <type>)] + + [jvm.boolean] + [jvm.byte] + [jvm.short] + [jvm.int] + [jvm.long] + [jvm.float] + [jvm.double] + [jvm.char])) + + (~~ (template [<type>] + [(text\= (..reflection (jvm.array <type>)) name) + (phase\wrap (jvm.array <type>))] + + [jvm.boolean] + [jvm.byte] + [jvm.short] + [jvm.int] + [jvm.long] + [jvm.float] + [jvm.double] + [jvm.char])) + + (text.starts_with? descriptor.array_prefix name) + (let [[_ unprefixed] (maybe.assume (text.split_with descriptor.array_prefix name))] + (\ phase.monad map jvm.array + (check_jvm (#.Primitive unprefixed (list))))) + + ## else + (phase\wrap (jvm.class name (list))))) + + (^ (#.Primitive (static array.type_name) + (list elementT))) + (|> elementT + check_jvm + (phase\map jvm.array)) + + (#.Primitive name parameters) + (do {! phase.monad} + [parameters (monad.map ! check_parameter parameters)] + (phase\wrap (jvm.class name parameters))) + + (#.Named name anonymous) + (check_jvm anonymous) + + (^template [<tag>] + [(<tag> env unquantified) + (check_jvm unquantified)]) + ([#.UnivQ] + [#.ExQ]) + + (#.Apply inputT abstractionT) + (case (type.apply (list inputT) abstractionT) + (#.Some outputT) + (check_jvm outputT) + + #.None + (/////analysis.throw ..non_object objectT)) + + _ + (check_parameter objectT))) + +(def: (check_object objectT) + (-> .Type (Operation External)) + (do {! phase.monad} + [name (\ ! map ..reflection (check_jvm objectT))] + (if (dictionary.key? ..boxes name) + (/////analysis.throw ..primitives_are_not_objects [name]) + (phase\wrap name)))) + +(def: (check_return type) + (-> .Type (Operation (Type Return))) + (if (is? .Any type) + (phase\wrap jvm.void) + (check_jvm type))) + +(def: (read_primitive_array_handler lux_type jvm_type) + (-> .Type (Type Primitive) Handler) + (function (_ extension_name analyse archive args) + (case args + (^ (list idxC arrayC)) + (do phase.monad + [_ (typeA.infer lux_type) + idxA (typeA.with_type ..int + (analyse archive idxC)) + arrayA (typeA.with_type (#.Primitive (|> (jvm.array jvm_type) ..reflection) + (list)) + (analyse archive arrayC))] + (wrap (#/////analysis.Extension extension_name (list idxA arrayA)))) + + _ + (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)])))) + +(def: array::read::object + Handler + (function (_ extension_name analyse archive args) + (case args + (^ (list idxC arrayC)) + (do phase.monad + [[var_id varT] (typeA.with_env check.var) + _ (typeA.infer varT) + arrayA (typeA.with_type (.type (array.Array varT)) + (analyse archive arrayC)) + varT (typeA.with_env + (check.clean varT)) + arrayJT (jvm_array_type (.type (array.Array varT))) + idxA (typeA.with_type ..int + (analyse archive idxC))] + (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT)) + idxA + arrayA)))) + + _ + (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)])))) + +(def: (write_primitive_array_handler lux_type jvm_type) + (-> .Type (Type Primitive) Handler) + (let [array_type (#.Primitive (|> (jvm.array jvm_type) ..reflection) + (list))] + (function (_ extension_name analyse archive args) + (case args + (^ (list idxC valueC arrayC)) + (do phase.monad + [_ (typeA.infer array_type) + idxA (typeA.with_type ..int + (analyse archive idxC)) + valueA (typeA.with_type lux_type + (analyse archive valueC)) + arrayA (typeA.with_type array_type + (analyse archive arrayC))] + (wrap (#/////analysis.Extension extension_name (list idxA + valueA + arrayA)))) + + _ + (/////analysis.throw ///.incorrect_arity [extension_name 3 (list.size args)]))))) + +(def: array::write::object + Handler + (function (_ extension_name analyse archive args) + (case args + (^ (list idxC valueC arrayC)) + (do phase.monad + [[var_id varT] (typeA.with_env check.var) + _ (typeA.infer (.type (array.Array varT))) + arrayA (typeA.with_type (.type (array.Array varT)) + (analyse archive arrayC)) + varT (typeA.with_env + (check.clean varT)) + arrayJT (jvm_array_type (.type (array.Array varT))) + idxA (typeA.with_type ..int + (analyse archive idxC)) + valueA (typeA.with_type varT + (analyse archive valueC))] + (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT)) + idxA + valueA + arrayA)))) + + _ + (/////analysis.throw ///.incorrect_arity [extension_name 3 (list.size args)])))) + +(def: bundle::array + Bundle + (<| (///bundle.prefix "array") + (|> ///bundle.empty + (dictionary.merge (<| (///bundle.prefix "length") + (|> ///bundle.empty + (///bundle.install (reflection.reflection reflection.boolean) (primitive_array_length_handler jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (primitive_array_length_handler jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (primitive_array_length_handler jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (primitive_array_length_handler jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (primitive_array_length_handler jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (primitive_array_length_handler jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (primitive_array_length_handler jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (primitive_array_length_handler jvm.char)) + (///bundle.install "object" array::length::object)))) + (dictionary.merge (<| (///bundle.prefix "new") + (|> ///bundle.empty + (///bundle.install (reflection.reflection reflection.boolean) (new_primitive_array_handler jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (new_primitive_array_handler jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (new_primitive_array_handler jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (new_primitive_array_handler jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (new_primitive_array_handler jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (new_primitive_array_handler jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (new_primitive_array_handler jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (new_primitive_array_handler jvm.char)) + (///bundle.install "object" array::new::object)))) + (dictionary.merge (<| (///bundle.prefix "read") + (|> ///bundle.empty + (///bundle.install (reflection.reflection reflection.boolean) (read_primitive_array_handler ..boolean jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (read_primitive_array_handler ..byte jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (read_primitive_array_handler ..short jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (read_primitive_array_handler ..int jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (read_primitive_array_handler ..long jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (read_primitive_array_handler ..float jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (read_primitive_array_handler ..double jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (read_primitive_array_handler ..char jvm.char)) + (///bundle.install "object" array::read::object)))) + (dictionary.merge (<| (///bundle.prefix "write") + (|> ///bundle.empty + (///bundle.install (reflection.reflection reflection.boolean) (write_primitive_array_handler ..boolean jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (write_primitive_array_handler ..byte jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (write_primitive_array_handler ..short jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (write_primitive_array_handler ..int jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (write_primitive_array_handler ..long jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (write_primitive_array_handler ..float jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (write_primitive_array_handler ..double jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (write_primitive_array_handler ..char jvm.char)) + (///bundle.install "object" array::write::object)))) + ))) + +(def: object::null + Handler + (function (_ extension_name analyse archive args) + (case args + (^ (list)) + (do phase.monad + [expectedT (///.lift meta.expected_type) + _ (check_object expectedT)] + (wrap (#/////analysis.Extension extension_name (list)))) + + _ + (/////analysis.throw ///.incorrect_arity [extension_name 0 (list.size args)])))) + +(def: object::null? + Handler + (function (_ extension_name analyse archive args) + (case args + (^ (list objectC)) + (do phase.monad + [_ (typeA.infer Bit) + [objectT objectA] (typeA.with_inference + (analyse archive objectC)) + _ (check_object objectT)] + (wrap (#/////analysis.Extension extension_name (list objectA)))) + + _ + (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def: object::synchronized + Handler + (function (_ extension_name analyse archive args) + (case args + (^ (list monitorC exprC)) + (do phase.monad + [[monitorT monitorA] (typeA.with_inference + (analyse archive monitorC)) + _ (check_object monitorT) + exprA (analyse archive exprC)] + (wrap (#/////analysis.Extension extension_name (list monitorA exprA)))) + + _ + (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)])))) + +(def: object::throw + Handler + (function (_ extension_name analyse archive args) + (case args + (^ (list exceptionC)) + (do phase.monad + [_ (typeA.infer Nothing) + [exceptionT exceptionA] (typeA.with_inference + (analyse archive exceptionC)) + exception_class (check_object exceptionT) + ? (phase.lift (reflection!.sub? "java.lang.Throwable" exception_class)) + _ (: (Operation Any) + (if ? + (wrap []) + (/////analysis.throw non_throwable exception_class)))] + (wrap (#/////analysis.Extension extension_name (list exceptionA)))) + + _ + (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def: object::class + Handler + (function (_ extension_name analyse archive args) + (case args + (^ (list classC)) + (case classC + [_ (#.Text class)] + (do phase.monad + [_ (..ensure_fresh_class! class) + _ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) + _ (phase.lift (reflection!.load class))] + (wrap (#/////analysis.Extension extension_name (list (/////analysis.text class))))) + + _ + (/////analysis.throw ///.invalid_syntax [extension_name %.code args])) + + _ + (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def: object::instance? + Handler + (..custom + [($_ <>.and <code>.text <code>.any) + (function (_ extension_name analyse archive [sub_class objectC]) + (do phase.monad + [_ (..ensure_fresh_class! sub_class) + _ (typeA.infer Bit) + [objectT objectA] (typeA.with_inference + (analyse archive objectC)) + object_class (check_object objectT) + ? (phase.lift (reflection!.sub? object_class sub_class))] + (if ? + (wrap (#/////analysis.Extension extension_name (list (/////analysis.text sub_class) objectA))) + (/////analysis.throw cannot_possibly_be_an_instance (format sub_class " !<= " object_class)))))])) + +(template [<name> <category> <parser>] + [(def: (<name> mapping typeJ) + (-> Mapping (Type <category>) (Operation .Type)) + (case (|> typeJ ..signature (<text>.run (<parser> mapping))) + (#try.Success check) + (typeA.with_env + check) + + (#try.Failure error) + (phase.fail error)))] + + [reflection_type Value luxT.type] + [reflection_return Return luxT.return] + ) + +(def: (class_candidate_parents from_name fromT to_name to_class) + (-> External .Type External (java/lang/Class java/lang/Object) (Operation (List [[Text .Type] Bit]))) + (do {! phase.monad} + [from_class (phase.lift (reflection!.load from_name)) + mapping (phase.lift (reflection!.correspond from_class fromT))] + (monad.map ! + (function (_ superJT) + (do ! + [superJT (phase.lift (reflection!.type superJT)) + #let [super_name (|> superJT ..reflection)] + super_class (phase.lift (reflection!.load super_name)) + superT (reflection_type mapping superJT)] + (wrap [[super_name superT] (java/lang/Class::isAssignableFrom super_class to_class)]))) + (case (java/lang/Class::getGenericSuperclass from_class) + (#.Some super) + (list& super (array.to_list (java/lang/Class::getGenericInterfaces from_class))) + + #.None + (if (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers from_class)) + (#.Cons (:as java/lang/reflect/Type (ffi.class_for java/lang/Object)) + (array.to_list (java/lang/Class::getGenericInterfaces from_class))) + (array.to_list (java/lang/Class::getGenericInterfaces from_class))))))) + +(def: (inheritance_candidate_parents fromT to_class toT fromC) + (-> .Type (java/lang/Class java/lang/Object) .Type Code (Operation (List [[Text .Type] Bit]))) + (case fromT + (^ (#.Primitive _ (list& self_classT super_classT super_interfacesT+))) + (monad.map phase.monad + (function (_ superT) + (do {! phase.monad} + [super_name (\ ! map ..reflection (check_jvm superT)) + super_class (phase.lift (reflection!.load super_name))] + (wrap [[super_name superT] + (java/lang/Class::isAssignableFrom super_class to_class)]))) + (list& super_classT super_interfacesT+)) + + _ + (/////analysis.throw ..cannot_cast [fromT toT fromC]))) + +(def: object::cast + Handler + (function (_ extension_name analyse archive args) + (case args + (^ (list fromC)) + (do {! phase.monad} + [toT (///.lift meta.expected_type) + to_name (\ ! map ..reflection (check_jvm toT)) + [fromT fromA] (typeA.with_inference + (analyse archive fromC)) + from_name (\ ! map ..reflection (check_jvm fromT)) + can_cast? (: (Operation Bit) + (`` (cond (~~ (template [<primitive> <object>] + [(let [=primitive (reflection.reflection <primitive>)] + (or (and (text\= =primitive from_name) + (or (text\= <object> to_name) + (text\= =primitive to_name))) + (and (text\= <object> from_name) + (text\= =primitive to_name)))) + (wrap true)] + + [reflection.boolean box.boolean] + [reflection.byte box.byte] + [reflection.short box.short] + [reflection.int box.int] + [reflection.long box.long] + [reflection.float box.float] + [reflection.double box.double] + [reflection.char box.char])) + + ## else + (do ! + [_ (phase.assert ..primitives_are_not_objects [from_name] + (not (dictionary.key? ..boxes from_name))) + _ (phase.assert ..primitives_are_not_objects [to_name] + (not (dictionary.key? ..boxes to_name))) + to_class (phase.lift (reflection!.load to_name)) + _ (if (text\= ..inheritance_relationship_type_name from_name) + (wrap []) + (do ! + [from_class (phase.lift (reflection!.load from_name))] + (phase.assert ..cannot_cast [fromT toT fromC] + (java/lang/Class::isAssignableFrom from_class to_class))))] + (loop [[current_name currentT] [from_name fromT]] + (if (text\= to_name current_name) + (wrap true) + (do ! + [candidate_parents (: (Operation (List [[Text .Type] Bit])) + (if (text\= ..inheritance_relationship_type_name current_name) + (inheritance_candidate_parents currentT to_class toT fromC) + (class_candidate_parents current_name currentT to_name to_class)))] + (case (|> candidate_parents + (list.filter product.right) + (list\map product.left)) + (#.Cons [next_name nextT] _) + (recur [next_name nextT]) + + #.Nil + (wrap false)))))))))] + (if can_cast? + (wrap (#/////analysis.Extension extension_name (list (/////analysis.text from_name) + (/////analysis.text to_name) + fromA))) + (/////analysis.throw ..cannot_cast [fromT toT fromC]))) + + _ + (/////analysis.throw ///.invalid_syntax [extension_name %.code args])))) + +(def: bundle::object + Bundle + (<| (///bundle.prefix "object") + (|> ///bundle.empty + (///bundle.install "null" object::null) + (///bundle.install "null?" object::null?) + (///bundle.install "synchronized" object::synchronized) + (///bundle.install "throw" object::throw) + (///bundle.install "class" object::class) + (///bundle.install "instance?" object::instance?) + (///bundle.install "cast" object::cast) + ))) + +(def: get::static + Handler + (..custom + [..member + (function (_ extension_name analyse archive [class field]) + (do phase.monad + [_ (..ensure_fresh_class! class) + [final? deprecated? fieldJT] (phase.lift + (do try.monad + [class (reflection!.load class)] + (reflection!.static_field field class))) + _ (phase.assert ..deprecated_field [class field] + (not deprecated?)) + fieldT (reflection_type luxT.fresh fieldJT) + _ (typeA.infer fieldT)] + (wrap (<| (#/////analysis.Extension extension_name) + (list (/////analysis.text class) + (/////analysis.text field) + (/////analysis.text (|> fieldJT ..reflection)))))))])) + +(def: put::static + Handler + (..custom + [($_ <>.and ..member <code>.any) + (function (_ extension_name analyse archive [[class field] valueC]) + (do phase.monad + [_ (..ensure_fresh_class! class) + _ (typeA.infer Any) + [final? deprecated? fieldJT] (phase.lift + (do try.monad + [class (reflection!.load class)] + (reflection!.static_field field class))) + _ (phase.assert ..deprecated_field [class field] + (not deprecated?)) + _ (phase.assert ..cannot_set_a_final_field [class field] + (not final?)) + fieldT (reflection_type luxT.fresh fieldJT) + valueA (typeA.with_type fieldT + (analyse archive valueC))] + (wrap (<| (#/////analysis.Extension extension_name) + (list (/////analysis.text class) + (/////analysis.text field) + valueA)))))])) + +(def: get::virtual + Handler + (..custom + [($_ <>.and ..member <code>.any) + (function (_ extension_name analyse archive [[class field] objectC]) + (do phase.monad + [_ (..ensure_fresh_class! class) + [objectT objectA] (typeA.with_inference + (analyse archive objectC)) + [deprecated? mapping fieldJT] (phase.lift + (do try.monad + [class (reflection!.load class) + [final? deprecated? fieldJT] (reflection!.virtual_field field class) + mapping (reflection!.correspond class objectT)] + (wrap [deprecated? mapping fieldJT]))) + _ (phase.assert ..deprecated_field [class field] + (not deprecated?)) + fieldT (reflection_type mapping fieldJT) + _ (typeA.infer fieldT)] + (wrap (<| (#/////analysis.Extension extension_name) + (list (/////analysis.text class) + (/////analysis.text field) + objectA)))))])) + +(def: put::virtual + Handler + (..custom + [($_ <>.and ..member <code>.any <code>.any) + (function (_ extension_name analyse archive [[class field] valueC objectC]) + (do phase.monad + [_ (..ensure_fresh_class! class) + [objectT objectA] (typeA.with_inference + (analyse archive objectC)) + _ (typeA.infer objectT) + [final? deprecated? mapping fieldJT] (phase.lift + (do try.monad + [class (reflection!.load class) + [final? deprecated? fieldJT] (reflection!.virtual_field field class) + mapping (reflection!.correspond class objectT)] + (wrap [final? deprecated? mapping fieldJT]))) + _ (phase.assert ..deprecated_field [class field] + (not deprecated?)) + _ (phase.assert ..cannot_set_a_final_field [class field] + (not final?)) + fieldT (reflection_type mapping fieldJT) + valueA (typeA.with_type fieldT + (analyse archive valueC))] + (wrap (<| (#/////analysis.Extension extension_name) + (list (/////analysis.text class) + (/////analysis.text field) + valueA + objectA)))))])) + +(type: Method_Style + #Static + #Abstract + #Virtual + #Special + #Interface) + +(def: (check_method aliasing class method_name method_style inputsJT method) + (-> Aliasing (java/lang/Class java/lang/Object) Text Method_Style (List (Type Value)) java/lang/reflect/Method (Operation Bit)) + (do phase.monad + [parameters (|> (java/lang/reflect/Method::getGenericParameterTypes method) + array.to_list + (monad.map try.monad reflection!.type) + phase.lift) + #let [modifiers (java/lang/reflect/Method::getModifiers method) + correct_class? (java/lang/Object::equals class (java/lang/reflect/Method::getDeclaringClass method)) + correct_method? (text\= method_name (java/lang/reflect/Method::getName method)) + static_matches? (case method_style + #Static + (java/lang/reflect/Modifier::isStatic modifiers) + + _ + true) + special_matches? (case method_style + #Special + (not (or (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class)) + (java/lang/reflect/Modifier::isAbstract modifiers))) + + _ + true) + arity_matches? (n.= (list.size inputsJT) (list.size parameters)) + inputs_match? (and arity_matches? + (list\fold (function (_ [expectedJC actualJC] prev) + (and prev + (jvm\= expectedJC (: (Type Value) + (case (jvm_parser.var? actualJC) + (#.Some name) + (|> aliasing + (dictionary.get name) + (maybe.default name) + jvm.var) + + #.None + actualJC))))) + true + (list.zip/2 parameters inputsJT)))]] + (wrap (and correct_class? + correct_method? + static_matches? + special_matches? + arity_matches? + inputs_match?)))) + +(def: (check_constructor aliasing class inputsJT constructor) + (-> Aliasing (java/lang/Class java/lang/Object) (List (Type Value)) (java/lang/reflect/Constructor java/lang/Object) (Operation Bit)) + (do phase.monad + [parameters (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor) + array.to_list + (monad.map try.monad reflection!.type) + phase.lift)] + (wrap (and (java/lang/Object::equals class (java/lang/reflect/Constructor::getDeclaringClass constructor)) + (n.= (list.size inputsJT) (list.size parameters)) + (list\fold (function (_ [expectedJC actualJC] prev) + (and prev + (jvm\= expectedJC (: (Type Value) + (case (jvm_parser.var? actualJC) + (#.Some name) + (|> aliasing + (dictionary.get name) + (maybe.default name) + jvm.var) + + #.None + actualJC))))) + true + (list.zip/2 parameters inputsJT)))))) + +(def: idx_to_parameter + (-> Nat .Type) + (|>> (n.* 2) inc #.Parameter)) + +(def: (jvm_type_var_mapping owner_tvars method_tvars) + (-> (List Text) (List Text) [(List .Type) Mapping]) + (let [jvm_tvars (list\compose owner_tvars method_tvars) + lux_tvars (|> jvm_tvars + list.reverse + list.enumeration + (list\map (function (_ [idx name]) + [name (idx_to_parameter idx)])) + list.reverse) + num_owner_tvars (list.size owner_tvars) + owner_tvarsT (|> lux_tvars (list.take num_owner_tvars) (list\map product.right)) + mapping (dictionary.from_list text.hash lux_tvars)] + [owner_tvarsT mapping])) + +(def: (method_signature method_style method) + (-> Method_Style java/lang/reflect/Method (Operation Method_Signature)) + (let [owner (java/lang/reflect/Method::getDeclaringClass method) + owner_tvars (case method_style + #Static + (list) + + _ + (|> (java/lang/Class::getTypeParameters owner) + array.to_list + (list\map (|>> java/lang/reflect/TypeVariable::getName)))) + method_tvars (|> (java/lang/reflect/Method::getTypeParameters method) + array.to_list + (list\map (|>> java/lang/reflect/TypeVariable::getName))) + [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)] + (do {! phase.monad} + [inputsT (|> (java/lang/reflect/Method::getGenericParameterTypes method) + array.to_list + (monad.map ! (|>> reflection!.type phase.lift)) + (phase\map (monad.map ! (..reflection_type mapping))) + phase\join) + outputT (|> method + java/lang/reflect/Method::getGenericReturnType + reflection!.return + phase.lift + (phase\map (..reflection_return mapping)) + phase\join) + exceptionsT (|> (java/lang/reflect/Method::getGenericExceptionTypes method) + array.to_list + (monad.map ! (|>> reflection!.type phase.lift)) + (phase\map (monad.map ! (..reflection_type mapping))) + phase\join) + #let [methodT (<| (type.univ_q (dictionary.size mapping)) + (type.function (case method_style + #Static + inputsT + + _ + (list& (#.Primitive (java/lang/Class::getName owner) owner_tvarsT) + inputsT))) + outputT)]] + (wrap [methodT + (reflection!.deprecated? (java/lang/reflect/Method::getDeclaredAnnotations method)) + exceptionsT])))) + +(def: (constructor_signature constructor) + (-> (java/lang/reflect/Constructor java/lang/Object) (Operation Method_Signature)) + (let [owner (java/lang/reflect/Constructor::getDeclaringClass constructor) + owner_tvars (|> (java/lang/Class::getTypeParameters owner) + array.to_list + (list\map (|>> java/lang/reflect/TypeVariable::getName))) + method_tvars (|> (java/lang/reflect/Constructor::getTypeParameters constructor) + array.to_list + (list\map (|>> java/lang/reflect/TypeVariable::getName))) + [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)] + (do {! phase.monad} + [inputsT (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor) + array.to_list + (monad.map ! (|>> reflection!.type phase.lift)) + (phase\map (monad.map ! (reflection_type mapping))) + phase\join) + exceptionsT (|> (java/lang/reflect/Constructor::getGenericExceptionTypes constructor) + array.to_list + (monad.map ! (|>> reflection!.type phase.lift)) + (phase\map (monad.map ! (reflection_type mapping))) + phase\join) + #let [objectT (#.Primitive (java/lang/Class::getName owner) owner_tvarsT) + constructorT (<| (type.univ_q (dictionary.size mapping)) + (type.function inputsT) + objectT)]] + (wrap [constructorT + (reflection!.deprecated? (java/lang/reflect/Constructor::getDeclaredAnnotations constructor)) + exceptionsT])))) + +(type: Evaluation + (#Pass Method_Signature) + (#Hint Method_Signature)) + +(template [<name> <tag>] + [(def: <name> + (-> Evaluation (Maybe Method_Signature)) + (|>> (case> (<tag> output) + (#.Some output) + + _ + #.None)))] + + [pass! #Pass] + [hint! #Hint] + ) + +(template [<name> <type> <method>] + [(def: <name> + (-> <type> (List (Type Var))) + (|>> <method> + array.to_list + (list\map (|>> java/lang/reflect/TypeVariable::getName jvm.var))))] + + [class_type_variables (java/lang/Class java/lang/Object) java/lang/Class::getTypeParameters] + [constructor_type_variables (java/lang/reflect/Constructor java/lang/Object) java/lang/reflect/Constructor::getTypeParameters] + [method_type_variables java/lang/reflect/Method java/lang/reflect/Method::getTypeParameters] + ) + +(def: (aliasing expected actual) + (-> (List (Type Var)) (List (Type Var)) Aliasing) + (|> (list.zip/2 (list\map jvm_parser.name actual) + (list\map jvm_parser.name expected)) + (dictionary.from_list text.hash))) + +(def: (method_candidate actual_class_tvars class_name actual_method_tvars method_name method_style inputsJT) + (-> (List (Type Var)) External (List (Type Var)) Text Method_Style (List (Type Value)) (Operation Method_Signature)) + (do {! phase.monad} + [class (phase.lift (reflection!.load class_name)) + #let [expected_class_tvars (class_type_variables class)] + candidates (|> class + java/lang/Class::getDeclaredMethods + array.to_list + (list.filter (|>> java/lang/reflect/Method::getName (text\= method_name))) + (monad.map ! (: (-> java/lang/reflect/Method (Operation Evaluation)) + (function (_ method) + (do ! + [#let [expected_method_tvars (method_type_variables method) + aliasing (dictionary.merge (..aliasing expected_class_tvars actual_class_tvars) + (..aliasing expected_method_tvars actual_method_tvars))] + passes? (check_method aliasing class method_name method_style inputsJT method)] + (\ ! map (if passes? + (|>> #Pass) + (|>> #Hint)) + (method_signature method_style method)))))))] + (case (list.all pass! candidates) + (#.Cons method #.Nil) + (wrap method) + + #.Nil + (/////analysis.throw ..no_candidates [class_name method_name inputsJT (list.all hint! candidates)]) + + candidates + (/////analysis.throw ..too_many_candidates [class_name method_name inputsJT candidates])))) + +(def: constructor_method + "<init>") + +(def: (constructor_candidate actual_class_tvars class_name actual_method_tvars inputsJT) + (-> (List (Type Var)) External (List (Type Var)) (List (Type Value)) (Operation Method_Signature)) + (do {! phase.monad} + [class (phase.lift (reflection!.load class_name)) + #let [expected_class_tvars (class_type_variables class)] + candidates (|> class + java/lang/Class::getConstructors + array.to_list + (monad.map ! (function (_ constructor) + (do ! + [#let [expected_method_tvars (constructor_type_variables constructor) + aliasing (dictionary.merge (..aliasing expected_class_tvars actual_class_tvars) + (..aliasing expected_method_tvars actual_method_tvars))] + passes? (check_constructor aliasing class inputsJT constructor)] + (\ ! map + (if passes? (|>> #Pass) (|>> #Hint)) + (constructor_signature constructor))))))] + (case (list.all pass! candidates) + (#.Cons constructor #.Nil) + (wrap constructor) + + #.Nil + (/////analysis.throw ..no_candidates [class_name ..constructor_method inputsJT (list.all hint! candidates)]) + + candidates + (/////analysis.throw ..too_many_candidates [class_name ..constructor_method inputsJT candidates])))) + +(template [<name> <category> <parser>] + [(def: #export <name> + (Parser (Type <category>)) + (<text>.embed <parser> <code>.text))] + + [var Var jvm_parser.var] + [class Class jvm_parser.class] + [type Value jvm_parser.value] + [return Return jvm_parser.return] + ) + +(def: input + (Parser (Typed Code)) + (<code>.tuple (<>.and ..type <code>.any))) + +(def: (decorate_inputs typesT inputsA) + (-> (List (Type Value)) (List Analysis) (List Analysis)) + (|> inputsA + (list.zip/2 (list\map (|>> ..signature /////analysis.text) typesT)) + (list\map (function (_ [type value]) + (/////analysis.tuple (list type value)))))) + +(def: type_vars + (<code>.tuple (<>.some ..var))) + +(def: invoke::static + Handler + (..custom + [($_ <>.and ..type_vars ..member ..type_vars (<>.some ..input)) + (function (_ extension_name analyse archive [class_tvars [class method] method_tvars argsTC]) + (do phase.monad + [_ (..ensure_fresh_class! class) + #let [argsT (list\map product.left argsTC)] + [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Static argsT) + _ (phase.assert ..deprecated_method [class method methodT] + (not deprecated?)) + [outputT argsA] (inferenceA.general archive analyse methodT (list\map product.right argsTC)) + outputJT (check_return outputT)] + (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list)))) + (/////analysis.text method) + (/////analysis.text (..signature outputJT)) + (decorate_inputs argsT argsA))))))])) + +(def: invoke::virtual + Handler + (..custom + [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input)) + (function (_ extension_name analyse archive [class_tvars [class method] method_tvars objectC argsTC]) + (do phase.monad + [_ (..ensure_fresh_class! class) + #let [argsT (list\map product.left argsTC)] + [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Virtual argsT) + _ (phase.assert ..deprecated_method [class method methodT] + (not deprecated?)) + [outputT allA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC))) + #let [[objectA argsA] (case allA + (#.Cons objectA argsA) + [objectA argsA] + + _ + (undefined))] + outputJT (check_return outputT)] + (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list)))) + (/////analysis.text method) + (/////analysis.text (..signature outputJT)) + objectA + (decorate_inputs argsT argsA))))))])) + +(def: invoke::special + Handler + (..custom + [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input)) + (function (_ extension_name analyse archive [class_tvars [class method] method_tvars objectC argsTC]) + (do phase.monad + [_ (..ensure_fresh_class! class) + #let [argsT (list\map product.left argsTC)] + [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Special argsT) + _ (phase.assert ..deprecated_method [class method methodT] + (not deprecated?)) + [outputT argsA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC))) + outputJT (check_return outputT)] + (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list)))) + (/////analysis.text method) + (/////analysis.text (..signature outputJT)) + (decorate_inputs argsT argsA))))))])) + +(def: invoke::interface + Handler + (..custom + [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input)) + (function (_ extension_name analyse archive [class_tvars [class_name method] method_tvars objectC argsTC]) + (do phase.monad + [_ (..ensure_fresh_class! class_name) + #let [argsT (list\map product.left argsTC)] + class (phase.lift (reflection!.load class_name)) + _ (phase.assert non_interface class_name + (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class))) + [methodT deprecated? exceptionsT] (..method_candidate class_tvars class_name method_tvars method #Interface argsT) + _ (phase.assert ..deprecated_method [class_name method methodT] + (not deprecated?)) + [outputT allA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC))) + #let [[objectA argsA] (case allA + (#.Cons objectA argsA) + [objectA argsA] + + _ + (undefined))] + outputJT (check_return outputT)] + (wrap (#/////analysis.Extension extension_name + (list& (/////analysis.text (..signature (jvm.class class_name (list)))) + (/////analysis.text method) + (/////analysis.text (..signature outputJT)) + objectA + (decorate_inputs argsT argsA))))))])) + +(def: invoke::constructor + (..custom + [($_ <>.and ..type_vars <code>.text ..type_vars (<>.some ..input)) + (function (_ extension_name analyse archive [class_tvars class method_tvars argsTC]) + (do phase.monad + [_ (..ensure_fresh_class! class) + #let [argsT (list\map product.left argsTC)] + [methodT deprecated? exceptionsT] (..constructor_candidate class_tvars class method_tvars argsT) + _ (phase.assert ..deprecated_method [class ..constructor_method methodT] + (not deprecated?)) + [outputT argsA] (inferenceA.general archive analyse methodT (list\map product.right argsTC))] + (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list)))) + (decorate_inputs argsT argsA))))))])) + +(def: bundle::member + Bundle + (<| (///bundle.prefix "member") + (|> ///bundle.empty + (dictionary.merge (<| (///bundle.prefix "get") + (|> ///bundle.empty + (///bundle.install "static" get::static) + (///bundle.install "virtual" get::virtual)))) + (dictionary.merge (<| (///bundle.prefix "put") + (|> ///bundle.empty + (///bundle.install "static" put::static) + (///bundle.install "virtual" put::virtual)))) + (dictionary.merge (<| (///bundle.prefix "invoke") + (|> ///bundle.empty + (///bundle.install "static" invoke::static) + (///bundle.install "virtual" invoke::virtual) + (///bundle.install "special" invoke::special) + (///bundle.install "interface" invoke::interface) + (///bundle.install "constructor" invoke::constructor) + ))) + ))) + +(type: #export (Annotation_Parameter a) + [Text a]) + +(def: annotation_parameter + (Parser (Annotation_Parameter Code)) + (<code>.tuple (<>.and <code>.text <code>.any))) + +(type: #export (Annotation a) + [Text (List (Annotation_Parameter a))]) + +(def: #export annotation + (Parser (Annotation Code)) + (<code>.form (<>.and <code>.text (<>.some ..annotation_parameter)))) + +(def: #export argument + (Parser Argument) + (<code>.tuple (<>.and <code>.text ..type))) + +(def: (annotation_parameter_analysis [name value]) + (-> (Annotation_Parameter Analysis) Analysis) + (/////analysis.tuple (list (/////analysis.text name) value))) + +(def: (annotation_analysis [name parameters]) + (-> (Annotation Analysis) Analysis) + (/////analysis.tuple (list& (/////analysis.text name) + (list\map annotation_parameter_analysis parameters)))) + +(template [<name> <category>] + [(def: <name> + (-> (Type <category>) Analysis) + (|>> ..signature /////analysis.text))] + + [var_analysis Var] + [class_analysis Class] + [value_analysis Value] + [return_analysis Return] + ) + +(def: (typed_analysis [type term]) + (-> (Typed Analysis) Analysis) + (/////analysis.tuple (list (value_analysis type) term))) + +(def: (argument_analysis [argument argumentJT]) + (-> Argument Analysis) + (/////analysis.tuple + (list (/////analysis.text argument) + (value_analysis argumentJT)))) + +(template [<name> <filter>] + [(def: <name> + (-> (java/lang/Class java/lang/Object) + (Try (List [Text (Type Method)]))) + (|>> java/lang/Class::getDeclaredMethods + array.to_list + <filter> + (monad.map try.monad + (function (_ method) + (do {! try.monad} + [inputs (|> (java/lang/reflect/Method::getGenericParameterTypes method) + array.to_list + (monad.map ! reflection!.type)) + return (|> method + java/lang/reflect/Method::getGenericReturnType + reflection!.return) + exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method) + array.to_list + (monad.map ! reflection!.class))] + (wrap [(java/lang/reflect/Method::getName method) + (jvm.method [inputs return exceptions])]))))))] + + [abstract_methods (list.filter (|>> java/lang/reflect/Method::getModifiers java/lang/reflect/Modifier::isAbstract))] + [methods (<|)] + ) + +(def: jvm_package_separator ".") + +(template [<name> <methods>] + [(def: <name> + (-> (List (Type Class)) (Try (List [Text (Type Method)]))) + (|>> (monad.map try.monad (|>> ..reflection reflection!.load)) + (try\map (monad.map try.monad <methods>)) + try\join + (try\map list\join)))] + + [all_abstract_methods ..abstract_methods] + [all_methods ..methods] + ) + +(template [<name>] + [(exception: #export (<name> {methods (List [Text (Type Method)])}) + (exception.report + ["Methods" (exception.enumerate + (function (_ [name type]) + (format (%.text name) " " (..signature type))) + methods)]))] + + [missing_abstract_methods] + [invalid_overriden_methods] + ) + +(type: #export Visibility + #Public + #Private + #Protected + #Default) + +(type: #export Finality Bit) +(type: #export Strictness Bit) + +(def: #export public_tag "public") +(def: #export private_tag "private") +(def: #export protected_tag "protected") +(def: #export default_tag "default") + +(def: #export visibility + (Parser Visibility) + ($_ <>.or + (<code>.text! ..public_tag) + (<code>.text! ..private_tag) + (<code>.text! ..protected_tag) + (<code>.text! ..default_tag))) + +(def: #export (visibility_analysis visibility) + (-> Visibility Analysis) + (/////analysis.text (case visibility + #Public ..public_tag + #Private ..private_tag + #Protected ..protected_tag + #Default ..default_tag))) + +(type: #export (Constructor a) + [Visibility + Strictness + (List (Annotation a)) + (List (Type Var)) + (List (Type Class)) ## Exceptions + Text + (List Argument) + (List (Typed a)) + a]) + +(def: #export constructor_tag "init") + +(def: #export constructor_definition + (Parser (Constructor Code)) + (<| <code>.form + (<>.after (<code>.text! ..constructor_tag)) + ($_ <>.and + ..visibility + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + (<code>.tuple (<>.some ..class)) + <code>.text + (<code>.tuple (<>.some ..argument)) + (<code>.tuple (<>.some ..input)) + <code>.any))) + +(def: #export (analyse_constructor_method analyse archive selfT mapping method) + (-> Phase Archive .Type Mapping (Constructor Code) (Operation Analysis)) + (let [[visibility strict_fp? + annotations vars exceptions + self_name arguments super_arguments body] method] + (do {! phase.monad} + [annotationsA (monad.map ! (function (_ [name parameters]) + (do ! + [parametersA (monad.map ! (function (_ [name value]) + (do ! + [valueA (analyse archive value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + super_arguments (monad.map ! (function (_ [jvmT super_argC]) + (do ! + [luxT (reflection_type mapping jvmT) + super_argA (typeA.with_type luxT + (analyse archive super_argC))] + (wrap [jvmT super_argA]))) + super_arguments) + arguments' (monad.map ! + (function (_ [name jvmT]) + (do ! + [luxT (reflection_type mapping jvmT)] + (wrap [name luxT]))) + arguments) + [scope bodyA] (|> arguments' + (#.Cons [self_name selfT]) + list.reverse + (list\fold scope.with_local (analyse archive body)) + (typeA.with_type .Any) + /////analysis.with_scope)] + (wrap (/////analysis.tuple (list (/////analysis.text ..constructor_tag) + (visibility_analysis visibility) + (/////analysis.bit strict_fp?) + (/////analysis.tuple (list\map annotation_analysis annotationsA)) + (/////analysis.tuple (list\map var_analysis vars)) + (/////analysis.text self_name) + (/////analysis.tuple (list\map ..argument_analysis arguments)) + (/////analysis.tuple (list\map class_analysis exceptions)) + (/////analysis.tuple (list\map typed_analysis super_arguments)) + (#/////analysis.Function + (list\map (|>> /////analysis.variable) + (scope.environment scope)) + (/////analysis.tuple (list bodyA))) + )))))) + +(type: #export (Virtual_Method a) + [Text + Visibility + Finality + Strictness + (List (Annotation a)) + (List (Type Var)) + Text + (List Argument) + (Type Return) + (List (Type Class)) ## Exceptions + a]) + +(def: virtual_tag "virtual") + +(def: #export virtual_method_definition + (Parser (Virtual_Method Code)) + (<| <code>.form + (<>.after (<code>.text! ..virtual_tag)) + ($_ <>.and + <code>.text + ..visibility + <code>.bit + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + <code>.text + (<code>.tuple (<>.some ..argument)) + ..return + (<code>.tuple (<>.some ..class)) + <code>.any))) + +(def: #export (analyse_virtual_method analyse archive selfT mapping method) + (-> Phase Archive .Type Mapping (Virtual_Method Code) (Operation Analysis)) + (let [[method_name visibility + final? strict_fp? annotations vars + self_name arguments return exceptions + body] method] + (do {! phase.monad} + [annotationsA (monad.map ! (function (_ [name parameters]) + (do ! + [parametersA (monad.map ! (function (_ [name value]) + (do ! + [valueA (analyse archive value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + returnT (reflection_return mapping return) + arguments' (monad.map ! + (function (_ [name jvmT]) + (do ! + [luxT (reflection_type mapping jvmT)] + (wrap [name luxT]))) + arguments) + [scope bodyA] (|> arguments' + (#.Cons [self_name selfT]) + list.reverse + (list\fold scope.with_local (analyse archive body)) + (typeA.with_type returnT) + /////analysis.with_scope)] + (wrap (/////analysis.tuple (list (/////analysis.text ..virtual_tag) + (/////analysis.text method_name) + (visibility_analysis visibility) + (/////analysis.bit final?) + (/////analysis.bit strict_fp?) + (/////analysis.tuple (list\map annotation_analysis annotationsA)) + (/////analysis.tuple (list\map var_analysis vars)) + (/////analysis.text self_name) + (/////analysis.tuple (list\map ..argument_analysis arguments)) + (return_analysis return) + (/////analysis.tuple (list\map class_analysis exceptions)) + (#/////analysis.Function + (list\map (|>> /////analysis.variable) + (scope.environment scope)) + (/////analysis.tuple (list bodyA))) + )))))) + +(type: #export (Static_Method a) + [Text + Visibility + Strictness + (List (Annotation a)) + (List (Type Var)) + (List (Type Class)) ## Exceptions + (List Argument) + (Type Return) + a]) + +(def: #export static_tag "static") + +(def: #export static_method_definition + (Parser (Static_Method Code)) + (<| <code>.form + (<>.after (<code>.text! ..static_tag)) + ($_ <>.and + <code>.text + ..visibility + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + (<code>.tuple (<>.some ..class)) + (<code>.tuple (<>.some ..argument)) + ..return + <code>.any))) + +(def: #export (analyse_static_method analyse archive mapping method) + (-> Phase Archive Mapping (Static_Method Code) (Operation Analysis)) + (let [[method_name visibility + strict_fp? annotations vars exceptions + arguments return + body] method] + (do {! phase.monad} + [annotationsA (monad.map ! (function (_ [name parameters]) + (do ! + [parametersA (monad.map ! (function (_ [name value]) + (do ! + [valueA (analyse archive value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + returnT (reflection_return mapping return) + arguments' (monad.map ! + (function (_ [name jvmT]) + (do ! + [luxT (reflection_type mapping jvmT)] + (wrap [name luxT]))) + arguments) + [scope bodyA] (|> arguments' + list.reverse + (list\fold scope.with_local (analyse archive body)) + (typeA.with_type returnT) + /////analysis.with_scope)] + (wrap (/////analysis.tuple (list (/////analysis.text ..static_tag) + (/////analysis.text method_name) + (visibility_analysis visibility) + (/////analysis.bit strict_fp?) + (/////analysis.tuple (list\map annotation_analysis annotationsA)) + (/////analysis.tuple (list\map var_analysis vars)) + (/////analysis.tuple (list\map ..argument_analysis arguments)) + (return_analysis return) + (/////analysis.tuple (list\map class_analysis + exceptions)) + (#/////analysis.Function + (list\map (|>> /////analysis.variable) + (scope.environment scope)) + (/////analysis.tuple (list bodyA))) + )))))) + +(type: #export (Overriden_Method a) + [(Type Class) + Text + Bit + (List (Annotation a)) + (List (Type Var)) + Text + (List Argument) + (Type Return) + (List (Type Class)) + a]) + +(def: #export overriden_tag "override") + +(def: #export overriden_method_definition + (Parser (Overriden_Method Code)) + (<| <code>.form + (<>.after (<code>.text! ..overriden_tag)) + ($_ <>.and + ..class + <code>.text + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + <code>.text + (<code>.tuple (<>.some ..argument)) + ..return + (<code>.tuple (<>.some ..class)) + <code>.any + ))) + +(def: #export (analyse_overriden_method analyse archive selfT mapping method) + (-> Phase Archive .Type Mapping (Overriden_Method Code) (Operation Analysis)) + (let [[parent_type method_name + strict_fp? annotations vars + self_name arguments return exceptions + body] method] + (do {! phase.monad} + [annotationsA (monad.map ! (function (_ [name parameters]) + (do ! + [parametersA (monad.map ! (function (_ [name value]) + (do ! + [valueA (analyse archive value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + returnT (reflection_return mapping return) + arguments' (monad.map ! + (function (_ [name jvmT]) + (do ! + [luxT (reflection_type mapping jvmT)] + (wrap [name luxT]))) + arguments) + [scope bodyA] (|> arguments' + (#.Cons [self_name selfT]) + list.reverse + (list\fold scope.with_local (analyse archive body)) + (typeA.with_type returnT) + /////analysis.with_scope)] + (wrap (/////analysis.tuple (list (/////analysis.text ..overriden_tag) + (class_analysis parent_type) + (/////analysis.text method_name) + (/////analysis.bit strict_fp?) + (/////analysis.tuple (list\map annotation_analysis annotationsA)) + (/////analysis.tuple (list\map var_analysis vars)) + (/////analysis.text self_name) + (/////analysis.tuple (list\map ..argument_analysis arguments)) + (return_analysis return) + (/////analysis.tuple (list\map class_analysis + exceptions)) + (#/////analysis.Function + (list\map (|>> /////analysis.variable) + (scope.environment scope)) + (/////analysis.tuple (list bodyA))) + )))))) + +(type: #export (Method_Definition a) + (#Overriden_Method (Overriden_Method a))) + +(def: #export parameter_types + (-> (List (Type Var)) (Check (List [(Type Var) .Type]))) + (monad.map check.monad + (function (_ parameterJ) + (do check.monad + [[_ parameterT] check.existential] + (wrap [parameterJ parameterT]))))) + +(def: (mismatched_methods super_set sub_set) + (-> (List [Text (Type Method)]) + (List [Text (Type Method)]) + (List [Text (Type Method)])) + (list.filter (function (_ [sub_name subJT]) + (|> super_set + (list.filter (function (_ [super_name superJT]) + (and (text\= super_name sub_name) + (jvm\= superJT subJT)))) + list.size + (n.= 1) + not)) + sub_set)) + +(exception: #export (class_parameter_mismatch {expected (List Text)} + {actual (List (Type Parameter))}) + (exception.report + ["Expected (amount)" (%.nat (list.size expected))] + ["Expected (parameters)" (exception.enumerate %.text expected)] + ["Actual (amount)" (%.nat (list.size actual))] + ["Actual (parameters)" (exception.enumerate ..signature actual)])) + +(def: (super_aliasing class) + (-> (Type Class) (Operation Aliasing)) + (do phase.monad + [#let [[name actual_parameters] (jvm_parser.read_class class)] + class (phase.lift (reflection!.load name)) + #let [expected_parameters (|> (java/lang/Class::getTypeParameters class) + array.to_list + (list\map (|>> java/lang/reflect/TypeVariable::getName)))] + _ (phase.assert ..class_parameter_mismatch [expected_parameters actual_parameters] + (n.= (list.size expected_parameters) + (list.size actual_parameters)))] + (wrap (|> (list.zip/2 expected_parameters actual_parameters) + (list\fold (function (_ [expected actual] mapping) + (case (jvm_parser.var? actual) + (#.Some actual) + (dictionary.put actual expected mapping) + + #.None + mapping)) + jvm_alias.fresh))))) + +(def: (anonymous_class_name module id) + (-> Module Nat Text) + (let [global (text.replace_all .module_separator ..jvm_package_separator module) + local (format "anonymous-class" (%.nat id))] + (format global ..jvm_package_separator local))) + +(def: class::anonymous + Handler + (..custom + [($_ <>.and + (<code>.tuple (<>.some ..var)) + ..class + (<code>.tuple (<>.some ..class)) + (<code>.tuple (<>.some ..input)) + (<code>.tuple (<>.some ..overriden_method_definition))) + (function (_ extension_name analyse archive [parameters + super_class + super_interfaces + constructor_args + methods]) + (do {! phase.monad} + [_ (..ensure_fresh_class! (..reflection super_class)) + _ (monad.map ! (|>> ..reflection ..ensure_fresh_class!) super_interfaces) + parameters (typeA.with_env + (..parameter_types parameters)) + #let [mapping (list\fold (function (_ [parameterJ parameterT] mapping) + (dictionary.put (jvm_parser.name parameterJ) + parameterT + mapping)) + luxT.fresh + parameters)] + super_classT (typeA.with_env + (luxT.check (luxT.class mapping) (..signature super_class))) + super_interfaceT+ (typeA.with_env + (monad.map check.monad + (|>> ..signature (luxT.check (luxT.class mapping))) + super_interfaces)) + selfT (///.lift (do meta.monad + [where meta.current_module_name + id meta.count] + (wrap (inheritance_relationship_type (#.Primitive (..anonymous_class_name where id) (list)) + super_classT + super_interfaceT+)))) + _ (typeA.infer selfT) + constructor_argsA+ (monad.map ! (function (_ [type term]) + (do ! + [argT (reflection_type mapping type) + termA (typeA.with_type argT + (analyse archive term))] + (wrap [type termA]))) + constructor_args) + methodsA (monad.map ! (analyse_overriden_method analyse archive selfT mapping) methods) + required_abstract_methods (phase.lift (all_abstract_methods (list& super_class super_interfaces))) + available_methods (phase.lift (all_methods (list& super_class super_interfaces))) + overriden_methods (monad.map ! (function (_ [parent_type method_name + strict_fp? annotations vars + self_name arguments return exceptions + body]) + (do ! + [aliasing (super_aliasing parent_type)] + (wrap [method_name (|> (jvm.method [(list\map product.right arguments) + return + exceptions]) + (jvm_alias.method aliasing))]))) + methods) + #let [missing_abstract_methods (mismatched_methods overriden_methods required_abstract_methods) + invalid_overriden_methods (mismatched_methods available_methods overriden_methods)] + _ (phase.assert ..missing_abstract_methods missing_abstract_methods + (list.empty? missing_abstract_methods)) + _ (phase.assert ..invalid_overriden_methods invalid_overriden_methods + (list.empty? invalid_overriden_methods))] + (wrap (#/////analysis.Extension extension_name + (list (class_analysis super_class) + (/////analysis.tuple (list\map class_analysis super_interfaces)) + (/////analysis.tuple (list\map typed_analysis constructor_argsA+)) + (/////analysis.tuple methodsA))))))])) + +(def: bundle::class + Bundle + (<| (///bundle.prefix "class") + (|> ///bundle.empty + (///bundle.install "anonymous" class::anonymous) + ))) + +(def: #export bundle + Bundle + (<| (///bundle.prefix "jvm") + (|> ///bundle.empty + (dictionary.merge bundle::conversion) + (dictionary.merge bundle::int) + (dictionary.merge bundle::long) + (dictionary.merge bundle::float) + (dictionary.merge bundle::double) + (dictionary.merge bundle::char) + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + (dictionary.merge bundle::member) + (dictionary.merge bundle::class) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux new file mode 100644 index 000000000..b0bdba0cb --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux @@ -0,0 +1,252 @@ +(.module: + [library + [lux #* + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + [collection + ["." array (#+ Array)] + ["." dictionary] + ["." list]]] + ["." type + ["." check]] + ["@" target + ["_" lua]]]] + [// + ["/" lux (#+ custom)] + [// + ["." bundle] + [// + ["." analysis #_ + ["#/." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) + +(def: Nil + (for {@.lua ffi.Nil} + Any)) + +(def: Object + (for {@.lua (type (ffi.Object Any))} + Any)) + +(def: Function + (for {@.lua ffi.Function} + Any)) + +(def: array::new + Handler + (custom + [<code>.any + (function (_ extension phase archive lengthC) + (do phase.monad + [lengthA (analysis/type.with_type Nat + (phase archive lengthC)) + [var_id varT] (analysis/type.with_env check.var) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list lengthA)))))])) + +(def: array::length + Handler + (custom + [<code>.any + (function (_ extension phase archive arrayC) + (do phase.monad + [[var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer Nat)] + (wrap (#analysis.Extension extension (list arrayA)))))])) + +(def: array::read + Handler + (custom + [(<>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer varT)] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: array::write + Handler + (custom + [($_ <>.and <code>.any <code>.any <code>.any) + (function (_ extension phase archive [indexC valueC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + valueA (analysis/type.with_type varT + (phase archive valueC)) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) + +(def: array::delete + Handler + (custom + [($_ <>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) + ))) + +(def: object::get + Handler + (custom + [($_ <>.and <code>.text <code>.any) + (function (_ extension phase archive [fieldC objectC]) + (do phase.monad + [objectA (analysis/type.with_type ..Object + (phase archive objectC)) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list (analysis.text fieldC) + objectA)))))])) + +(def: object::do + Handler + (custom + [($_ <>.and <code>.text <code>.any (<>.some <code>.any)) + (function (_ extension phase archive [methodC objectC inputsC]) + (do {! phase.monad} + [objectA (analysis/type.with_type ..Object + (phase archive objectC)) + inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list& (analysis.text methodC) + objectA + inputsA)))))])) + +(def: bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "get" object::get) + (bundle.install "do" object::do) + (bundle.install "nil" (/.nullary ..Nil)) + (bundle.install "nil?" (/.unary Any Bit)) + ))) + +(template [<name> <fromT> <toT>] + [(def: <name> + Handler + (custom + [<code>.any + (function (_ extension phase archive inputC) + (do {! phase.monad} + [inputA (analysis/type.with_type (type <fromT>) + (phase archive inputC)) + _ (analysis/type.infer (type <toT>))] + (wrap (#analysis.Extension extension (list inputA)))))]))] + + [utf8::encode Text (array.Array (I64 Any))] + [utf8::decode (array.Array (I64 Any)) Text] + ) + +(def: bundle::utf8 + Bundle + (<| (bundle.prefix "utf8") + (|> bundle.empty + (bundle.install "encode" utf8::encode) + (bundle.install "decode" utf8::decode) + ))) + +(def: lua::constant + Handler + (custom + [<code>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list (analysis.text name))))))])) + +(def: lua::apply + Handler + (custom + [($_ <>.and <code>.any (<>.some <code>.any)) + (function (_ extension phase archive [abstractionC inputsC]) + (do {! phase.monad} + [abstractionA (analysis/type.with_type ..Function + (phase archive abstractionC)) + inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) + +(def: lua::power + Handler + (custom + [($_ <>.and <code>.any <code>.any) + (function (_ extension phase archive [powerC baseC]) + (do {! phase.monad} + [powerA (analysis/type.with_type Frac + (phase archive powerC)) + baseA (analysis/type.with_type Frac + (phase archive baseC)) + _ (analysis/type.infer Frac)] + (wrap (#analysis.Extension extension (list powerA baseA)))))])) + +(def: lua::import + Handler + (custom + [<code>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.infer ..Object)] + (wrap (#analysis.Extension extension (list (analysis.text name))))))])) + +(def: lua::function + Handler + (custom + [($_ <>.and <code>.nat <code>.any) + (function (_ extension phase archive [arity abstractionC]) + (do phase.monad + [#let [inputT (type.tuple (list.repeat arity Any))] + abstractionA (analysis/type.with_type (-> inputT Any) + (phase archive abstractionC)) + _ (analysis/type.infer ..Function)] + (wrap (#analysis.Extension extension (list (analysis.nat arity) + abstractionA)))))])) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lua") + (|> bundle.empty + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + (dictionary.merge bundle::utf8) + + (bundle.install "constant" lua::constant) + (bundle.install "apply" lua::apply) + (bundle.install "power" lua::power) + (bundle.install "import" lua::import) + (bundle.install "function" lua::function) + (bundle.install "script universe" (/.nullary .Bit)) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux new file mode 100644 index 000000000..a5e924af1 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux @@ -0,0 +1,301 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)] + ["." dictionary (#+ Dictionary)]]] + [math + [number + ["n" nat]]] + [type + ["." check]] + ["." meta]]] + ["." /// + ["#." bundle] + ["/#" // #_ + [analysis + [".A" type]] + [// + ["#." analysis (#+ Analysis Operation Phase Handler Bundle) + [evaluation (#+ Eval)]] + [/// + ["#" phase] + [meta + [archive (#+ Archive)]]]]]]) + +(def: #export (custom [syntax handler]) + (All [s] + (-> [(Parser s) + (-> Text Phase Archive s (Operation Analysis))] + Handler)) + (function (_ extension_name analyse archive args) + (case (<code>.run syntax args) + (#try.Success inputs) + (handler extension_name analyse archive inputs) + + (#try.Failure _) + (////analysis.throw ///.invalid_syntax [extension_name %.code args])))) + +(def: (simple inputsT+ outputT) + (-> (List Type) Type Handler) + (let [num_expected (list.size inputsT+)] + (function (_ extension_name analyse archive args) + (let [num_actual (list.size args)] + (if (n.= num_expected num_actual) + (do {! ////.monad} + [_ (typeA.infer outputT) + argsA (monad.map ! + (function (_ [argT argC]) + (typeA.with_type argT + (analyse archive argC))) + (list.zip/2 inputsT+ args))] + (wrap (#////analysis.Extension extension_name argsA))) + (////analysis.throw ///.incorrect_arity [extension_name num_expected num_actual])))))) + +(def: #export (nullary valueT) + (-> Type Handler) + (simple (list) valueT)) + +(def: #export (unary inputT outputT) + (-> Type Type Handler) + (simple (list inputT) outputT)) + +(def: #export (binary subjectT paramT outputT) + (-> Type Type Type Handler) + (simple (list subjectT paramT) outputT)) + +(def: #export (trinary subjectT param0T param1T outputT) + (-> Type Type Type Type Handler) + (simple (list subjectT param0T param1T) outputT)) + +## TODO: Get rid of this ASAP +(as_is + (exception: #export (char_text_must_be_size_1 {text Text}) + (exception.report + ["Text" (%.text text)])) + + (def: text_char + (Parser text.Char) + (do <>.monad + [raw <code>.text] + (case (text.size raw) + 1 (wrap (|> raw (text.nth 0) maybe.assume)) + _ (<>.fail (exception.construct ..char_text_must_be_size_1 [raw]))))) + + (def: lux::syntax_char_case! + (..custom + [($_ <>.and + <code>.any + (<code>.tuple (<>.some (<>.and (<code>.tuple (<>.many ..text_char)) + <code>.any))) + <code>.any) + (function (_ extension_name phase archive [input conditionals else]) + (do {! ////.monad} + [input (typeA.with_type text.Char + (phase archive input)) + expectedT (///.lift meta.expected_type) + conditionals (monad.map ! (function (_ [cases branch]) + (do ! + [branch (typeA.with_type expectedT + (phase archive branch))] + (wrap [cases branch]))) + conditionals) + else (typeA.with_type expectedT + (phase archive else))] + (wrap (|> conditionals + (list\map (function (_ [cases branch]) + (////analysis.tuple + (list (////analysis.tuple (list\map (|>> ////analysis.nat) cases)) + branch)))) + (list& input else) + (#////analysis.Extension extension_name)))))]))) + +## "lux is" represents reference/pointer equality. +(def: lux::is + Handler + (function (_ extension_name analyse archive args) + (do ////.monad + [[var_id varT] (typeA.with_env check.var)] + ((binary varT varT Bit extension_name) + analyse archive args)))) + +## "lux try" provides a simple way to interact with the host platform's +## error_handling facilities. +(def: lux::try + Handler + (function (_ extension_name analyse archive args) + (case args + (^ (list opC)) + (do ////.monad + [[var_id varT] (typeA.with_env check.var) + _ (typeA.infer (type (Either Text varT))) + opA (typeA.with_type (type (-> .Any varT)) + (analyse archive opC))] + (wrap (#////analysis.Extension extension_name (list opA)))) + + _ + (////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def: lux::in_module + Handler + (function (_ extension_name analyse archive argsC+) + (case argsC+ + (^ (list [_ (#.Text module_name)] exprC)) + (////analysis.with_current_module module_name + (analyse archive exprC)) + + _ + (////analysis.throw ///.invalid_syntax [extension_name %.code argsC+])))) + +(def: (lux::type::check eval) + (-> Eval Handler) + (function (_ extension_name analyse archive args) + (case args + (^ (list typeC valueC)) + (do {! ////.monad} + [count (///.lift meta.count) + actualT (\ ! map (|>> (:as Type)) + (eval archive count Type typeC)) + _ (typeA.infer actualT)] + (typeA.with_type actualT + (analyse archive valueC))) + + _ + (////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)])))) + +(def: (lux::type::as eval) + (-> Eval Handler) + (function (_ extension_name analyse archive args) + (case args + (^ (list typeC valueC)) + (do {! ////.monad} + [count (///.lift meta.count) + actualT (\ ! map (|>> (:as Type)) + (eval archive count Type typeC)) + _ (typeA.infer actualT) + [valueT valueA] (typeA.with_inference + (analyse archive valueC))] + (wrap valueA)) + + _ + (////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)])))) + +(def: (caster input output) + (-> Type Type Handler) + (..custom + [<code>.any + (function (_ extension_name phase archive valueC) + (do {! ////.monad} + [_ (typeA.infer output)] + (typeA.with_type input + (phase archive valueC))))])) + +(def: lux::macro + Handler + (..custom + [<code>.any + (function (_ extension_name phase archive valueC) + (do {! ////.monad} + [_ (typeA.infer .Macro) + input_type (loop [input_name (name_of .Macro')] + (do ! + [input_type (///.lift (meta.find_def (name_of .Macro')))] + (case input_type + (#.Definition [exported? def_type def_data def_value]) + (wrap (:as Type def_value)) + + (#.Alias real_name) + (recur real_name))))] + (typeA.with_type input_type + (phase archive valueC))))])) + +(def: (bundle::lux eval) + (-> Eval Bundle) + (|> ///bundle.empty + (///bundle.install "syntax char case!" lux::syntax_char_case!) + (///bundle.install "is" lux::is) + (///bundle.install "try" lux::try) + (///bundle.install "type check" (lux::type::check eval)) + (///bundle.install "type as" (lux::type::as eval)) + (///bundle.install "macro" ..lux::macro) + (///bundle.install "type check type" (..caster .Type .Type)) + (///bundle.install "in-module" lux::in_module))) + +(def: bundle::io + Bundle + (<| (///bundle.prefix "io") + (|> ///bundle.empty + (///bundle.install "log" (unary Text Any)) + (///bundle.install "error" (unary Text Nothing)) + (///bundle.install "exit" (unary Int Nothing))))) + +(def: I64* (type (I64 Any))) + +(def: bundle::i64 + Bundle + (<| (///bundle.prefix "i64") + (|> ///bundle.empty + (///bundle.install "and" (binary I64* I64* I64)) + (///bundle.install "or" (binary I64* I64* I64)) + (///bundle.install "xor" (binary I64* I64* I64)) + (///bundle.install "left-shift" (binary Nat I64* I64)) + (///bundle.install "right-shift" (binary Nat I64* I64)) + (///bundle.install "=" (binary I64* I64* Bit)) + (///bundle.install "<" (binary Int Int Bit)) + (///bundle.install "+" (binary I64* I64* I64)) + (///bundle.install "-" (binary I64* I64* I64)) + (///bundle.install "*" (binary Int Int Int)) + (///bundle.install "/" (binary Int Int Int)) + (///bundle.install "%" (binary Int Int Int)) + (///bundle.install "f64" (unary Int Frac)) + (///bundle.install "char" (unary Int Text))))) + +(def: bundle::f64 + Bundle + (<| (///bundle.prefix "f64") + (|> ///bundle.empty + (///bundle.install "+" (binary Frac Frac Frac)) + (///bundle.install "-" (binary Frac Frac Frac)) + (///bundle.install "*" (binary Frac Frac Frac)) + (///bundle.install "/" (binary Frac Frac Frac)) + (///bundle.install "%" (binary Frac Frac Frac)) + (///bundle.install "=" (binary Frac Frac Bit)) + (///bundle.install "<" (binary Frac Frac Bit)) + (///bundle.install "i64" (unary Frac Int)) + (///bundle.install "encode" (unary Frac Text)) + (///bundle.install "decode" (unary Text (type (Maybe Frac))))))) + +(def: bundle::text + Bundle + (<| (///bundle.prefix "text") + (|> ///bundle.empty + (///bundle.install "=" (binary Text Text Bit)) + (///bundle.install "<" (binary Text Text Bit)) + (///bundle.install "concat" (binary Text Text Text)) + (///bundle.install "index" (trinary Nat Text Text (type (Maybe Nat)))) + (///bundle.install "size" (unary Text Nat)) + (///bundle.install "char" (binary Nat Text Nat)) + (///bundle.install "clip" (trinary Nat Nat Text Text)) + ))) + +(def: #export (bundle eval) + (-> Eval Bundle) + (<| (///bundle.prefix "lux") + (|> ///bundle.empty + (dictionary.merge (bundle::lux eval)) + (dictionary.merge bundle::i64) + (dictionary.merge bundle::f64) + (dictionary.merge bundle::text) + (dictionary.merge bundle::io) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux new file mode 100644 index 000000000..a30c9e6f0 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux @@ -0,0 +1,214 @@ +(.module: + [library + [lux #* + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]]] + [data + [collection + ["." array (#+ Array)] + ["." dictionary] + ["." list]]] + ["." type + ["." check]] + ["@" target + ["_" php]]]] + [// + ["/" lux (#+ custom)] + [// + ["." bundle] + [// + ["." analysis #_ + ["#/." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) + +(def: array::new + Handler + (custom + [<c>.any + (function (_ extension phase archive lengthC) + (do phase.monad + [lengthA (analysis/type.with_type Nat + (phase archive lengthC)) + [var_id varT] (analysis/type.with_env check.var) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list lengthA)))))])) + +(def: array::length + Handler + (custom + [<c>.any + (function (_ extension phase archive arrayC) + (do phase.monad + [[var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer Nat)] + (wrap (#analysis.Extension extension (list arrayA)))))])) + +(def: array::read + Handler + (custom + [(<>.and <c>.any <c>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer varT)] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: array::write + Handler + (custom + [($_ <>.and <c>.any <c>.any <c>.any) + (function (_ extension phase archive [indexC valueC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + valueA (analysis/type.with_type varT + (phase archive valueC)) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) + +(def: array::delete + Handler + (custom + [($_ <>.and <c>.any <c>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) + ))) + +(def: Null + (for {@.php ffi.Null} + Any)) + +(def: Object + (for {@.php (type (ffi.Object Any))} + Any)) + +(def: Function + (for {@.php ffi.Function} + Any)) + +(def: object::new + Handler + (custom + [($_ <>.and <c>.text (<>.some <c>.any)) + (function (_ extension phase archive [constructor inputsC]) + (do {! phase.monad} + [inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list& (analysis.text constructor) inputsA)))))])) + +(def: object::get + Handler + (custom + [($_ <>.and <c>.text <c>.any) + (function (_ extension phase archive [fieldC objectC]) + (do phase.monad + [objectA (analysis/type.with_type ..Object + (phase archive objectC)) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list (analysis.text fieldC) + objectA)))))])) + +(def: object::do + Handler + (custom + [($_ <>.and <c>.text <c>.any (<>.some <c>.any)) + (function (_ extension phase archive [methodC objectC inputsC]) + (do {! phase.monad} + [objectA (analysis/type.with_type ..Object + (phase archive objectC)) + inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list& (analysis.text methodC) + objectA + inputsA)))))])) + +(def: bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "new" object::new) + (bundle.install "get" object::get) + (bundle.install "do" object::do) + (bundle.install "null" (/.nullary ..Null)) + (bundle.install "null?" (/.unary Any Bit)) + ))) + +(def: php::constant + Handler + (custom + [<c>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list (analysis.text name))))))])) + +(def: php::apply + Handler + (custom + [($_ <>.and <c>.any (<>.some <c>.any)) + (function (_ extension phase archive [abstractionC inputsC]) + (do {! phase.monad} + [abstractionA (analysis/type.with_type ..Function + (phase archive abstractionC)) + inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) + +(def: php::pack + Handler + (custom + [($_ <>.and <c>.any <c>.any) + (function (_ extension phase archive [formatC dataC]) + (do {! phase.monad} + [formatA (analysis/type.with_type Text + (phase archive formatC)) + dataA (analysis/type.with_type (type (Array (I64 Any))) + (phase archive dataC)) + _ (analysis/type.infer Text)] + (wrap (#analysis.Extension extension (list formatA dataA)))))])) + +(def: #export bundle + Bundle + (<| (bundle.prefix "php") + (|> bundle.empty + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + + (bundle.install "constant" php::constant) + (bundle.install "apply" php::apply) + (bundle.install "pack" php::pack) + (bundle.install "script universe" (/.nullary .Bit)) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux new file mode 100644 index 000000000..a3635cf96 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux @@ -0,0 +1,231 @@ +(.module: + [library + [lux #* + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + [collection + ["." array (#+ Array)] + ["." dictionary] + ["." list]]] + ["." type + ["." check]] + ["@" target + ["_" python]]]] + [// + ["/" lux (#+ custom)] + [// + ["." bundle] + [// + ["." analysis #_ + ["#/." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) + +(def: array::new + Handler + (custom + [<code>.any + (function (_ extension phase archive lengthC) + (do phase.monad + [lengthA (analysis/type.with_type Nat + (phase archive lengthC)) + [var_id varT] (analysis/type.with_env check.var) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list lengthA)))))])) + +(def: array::length + Handler + (custom + [<code>.any + (function (_ extension phase archive arrayC) + (do phase.monad + [[var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer Nat)] + (wrap (#analysis.Extension extension (list arrayA)))))])) + +(def: array::read + Handler + (custom + [(<>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer varT)] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: array::write + Handler + (custom + [($_ <>.and <code>.any <code>.any <code>.any) + (function (_ extension phase archive [indexC valueC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + valueA (analysis/type.with_type varT + (phase archive valueC)) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) + +(def: array::delete + Handler + (custom + [($_ <>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) + ))) + +(def: None + (for {@.python + ffi.None} + Any)) + +(def: Object + (for {@.python (type (ffi.Object Any))} + Any)) + +(def: Function + (for {@.python ffi.Function} + Any)) + +(def: Dict + (for {@.python ffi.Dict} + Any)) + +(def: object::get + Handler + (custom + [($_ <>.and <code>.text <code>.any) + (function (_ extension phase archive [fieldC objectC]) + (do phase.monad + [objectA (analysis/type.with_type ..Object + (phase archive objectC)) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list (analysis.text fieldC) + objectA)))))])) + +(def: object::do + Handler + (custom + [($_ <>.and <code>.text <code>.any (<>.some <code>.any)) + (function (_ extension phase archive [methodC objectC inputsC]) + (do {! phase.monad} + [objectA (analysis/type.with_type ..Object + (phase archive objectC)) + inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list& (analysis.text methodC) + objectA + inputsA)))))])) + +(def: bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "get" object::get) + (bundle.install "do" object::do) + (bundle.install "none" (/.nullary ..None)) + (bundle.install "none?" (/.unary Any Bit)) + ))) + +(def: python::constant + Handler + (custom + [<code>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list (analysis.text name))))))])) + +(def: python::import + Handler + (custom + [<code>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.infer ..Object)] + (wrap (#analysis.Extension extension (list (analysis.text name))))))])) + +(def: python::apply + Handler + (custom + [($_ <>.and <code>.any (<>.some <code>.any)) + (function (_ extension phase archive [abstractionC inputsC]) + (do {! phase.monad} + [abstractionA (analysis/type.with_type ..Function + (phase archive abstractionC)) + inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) + +(def: python::function + Handler + (custom + [($_ <>.and <code>.nat <code>.any) + (function (_ extension phase archive [arity abstractionC]) + (do phase.monad + [#let [inputT (type.tuple (list.repeat arity Any))] + abstractionA (analysis/type.with_type (-> inputT Any) + (phase archive abstractionC)) + _ (analysis/type.infer ..Function)] + (wrap (#analysis.Extension extension (list (analysis.nat arity) + abstractionA)))))])) + +(def: python::exec + Handler + (custom + [($_ <>.and <code>.any <code>.any) + (function (_ extension phase archive [codeC globalsC]) + (do phase.monad + [codeA (analysis/type.with_type Text + (phase archive codeC)) + globalsA (analysis/type.with_type ..Dict + (phase archive globalsC)) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list codeA globalsA)))))])) + +(def: #export bundle + Bundle + (<| (bundle.prefix "python") + (|> bundle.empty + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + + (bundle.install "constant" python::constant) + (bundle.install "import" python::import) + (bundle.install "apply" python::apply) + (bundle.install "function" python::function) + (bundle.install "exec" python::exec) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux new file mode 100644 index 000000000..6dfbf707e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux @@ -0,0 +1,35 @@ +(.module: + [library + [lux #* + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]]] + [data + [collection + ["." array (#+ Array)] + ["." dictionary] + ["." list]]] + ["." type + ["." check]] + ["@" target + ["_" r]]]] + [// + ["/" lux (#+ custom)] + [// + ["." bundle] + [// + ["." analysis #_ + ["#/." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) + +(def: #export bundle + Bundle + (<| (bundle.prefix "r") + (|> bundle.empty + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux new file mode 100644 index 000000000..1d01b479d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux @@ -0,0 +1,199 @@ +(.module: + [library + [lux #* + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]]] + [data + [collection + ["." array (#+ Array)] + ["." dictionary] + ["." list]]] + ["." type + ["." check]] + ["@" target + ["_" ruby]]]] + [// + ["/" lux (#+ custom)] + [// + ["." bundle] + [// + ["." analysis #_ + ["#/." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) + +(def: array::new + Handler + (custom + [<c>.any + (function (_ extension phase archive lengthC) + (do phase.monad + [lengthA (analysis/type.with_type Nat + (phase archive lengthC)) + [var_id varT] (analysis/type.with_env check.var) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list lengthA)))))])) + +(def: array::length + Handler + (custom + [<c>.any + (function (_ extension phase archive arrayC) + (do phase.monad + [[var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer Nat)] + (wrap (#analysis.Extension extension (list arrayA)))))])) + +(def: array::read + Handler + (custom + [(<>.and <c>.any <c>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer varT)] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: array::write + Handler + (custom + [($_ <>.and <c>.any <c>.any <c>.any) + (function (_ extension phase archive [indexC valueC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + valueA (analysis/type.with_type varT + (phase archive valueC)) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) + +(def: array::delete + Handler + (custom + [($_ <>.and <c>.any <c>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) + ))) + +(def: Nil + (for {@.ruby ffi.Nil} + Any)) + +(def: Object + (for {@.ruby (type (ffi.Object Any))} + Any)) + +(def: Function + (for {@.ruby ffi.Function} + Any)) + +(def: object::get + Handler + (custom + [($_ <>.and <c>.text <c>.any) + (function (_ extension phase archive [fieldC objectC]) + (do phase.monad + [objectA (analysis/type.with_type ..Object + (phase archive objectC)) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list (analysis.text fieldC) + objectA)))))])) + +(def: object::do + Handler + (custom + [($_ <>.and <c>.text <c>.any (<>.some <c>.any)) + (function (_ extension phase archive [methodC objectC inputsC]) + (do {! phase.monad} + [objectA (analysis/type.with_type ..Object + (phase archive objectC)) + inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list& (analysis.text methodC) + objectA + inputsA)))))])) + +(def: bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "get" object::get) + (bundle.install "do" object::do) + (bundle.install "nil" (/.nullary ..Nil)) + (bundle.install "nil?" (/.unary Any Bit)) + ))) + +(def: ruby::constant + Handler + (custom + [<c>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list (analysis.text name))))))])) + +(def: ruby::apply + Handler + (custom + [($_ <>.and <c>.any (<>.some <c>.any)) + (function (_ extension phase archive [abstractionC inputsC]) + (do {! phase.monad} + [abstractionA (analysis/type.with_type ..Function + (phase archive abstractionC)) + inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) + +(def: ruby::import + Handler + (custom + [<c>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.infer Bit)] + (wrap (#analysis.Extension extension (list (analysis.text name))))))])) + +(def: #export bundle + Bundle + (<| (bundle.prefix "ruby") + (|> bundle.empty + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + + (bundle.install "constant" ruby::constant) + (bundle.install "apply" ruby::apply) + (bundle.install "import" ruby::import) + (bundle.install "script universe" (/.nullary .Bit)) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux new file mode 100644 index 000000000..e7ff4ba15 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux @@ -0,0 +1,158 @@ +(.module: + [library + [lux #* + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]]] + [data + [collection + ["." array (#+ Array)] + ["." dictionary] + ["." list]]] + ["." type + ["." check]] + ["@" target + ["_" scheme]]]] + [// + ["/" lux (#+ custom)] + [// + ["." bundle] + [// + ["." analysis #_ + ["#/." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) + +(def: array::new + Handler + (custom + [<c>.any + (function (_ extension phase archive lengthC) + (do phase.monad + [lengthA (analysis/type.with_type Nat + (phase archive lengthC)) + [var_id varT] (analysis/type.with_env check.var) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list lengthA)))))])) + +(def: array::length + Handler + (custom + [<c>.any + (function (_ extension phase archive arrayC) + (do phase.monad + [[var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer Nat)] + (wrap (#analysis.Extension extension (list arrayA)))))])) + +(def: array::read + Handler + (custom + [(<>.and <c>.any <c>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer varT)] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: array::write + Handler + (custom + [($_ <>.and <c>.any <c>.any <c>.any) + (function (_ extension phase archive [indexC valueC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + valueA (analysis/type.with_type varT + (phase archive valueC)) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) + +(def: array::delete + Handler + (custom + [($_ <>.and <c>.any <c>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) + ))) + +(def: Nil + (for {@.scheme + ffi.Nil} + Any)) + +(def: Function + (for {@.scheme ffi.Function} + Any)) + +(def: bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "nil" (/.nullary ..Nil)) + (bundle.install "nil?" (/.unary Any Bit)) + ))) + +(def: scheme::constant + Handler + (custom + [<c>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list (analysis.text name))))))])) + +(def: scheme::apply + Handler + (custom + [($_ <>.and <c>.any (<>.some <c>.any)) + (function (_ extension phase archive [abstractionC inputsC]) + (do {! phase.monad} + [abstractionA (analysis/type.with_type ..Function + (phase archive abstractionC)) + inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) + +(def: #export bundle + Bundle + (<| (bundle.prefix "scheme") + (|> bundle.empty + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + + (bundle.install "constant" scheme::constant) + (bundle.install "apply" scheme::apply) + (bundle.install "script universe" (/.nullary .Bit)) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/bundle.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/bundle.lux new file mode 100644 index 000000000..3fb0c967e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/bundle.lux @@ -0,0 +1,29 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)] + ["." dictionary (#+ Dictionary)]]]]] + [// (#+ Handler Bundle)]) + +(def: #export empty + Bundle + (dictionary.new text.hash)) + +(def: #export (install name anonymous) + (All [s i o] + (-> Text (Handler s i o) + (-> (Bundle s i o) (Bundle s i o)))) + (dictionary.put name anonymous)) + +(def: #export (prefix prefix) + (All [s i o] + (-> Text (-> (Bundle s i o) (Bundle s i o)))) + (|>> dictionary.entries + (list\map (function (_ [key val]) [(format prefix " " key) val])) + (dictionary.from_list text.hash))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux new file mode 100644 index 000000000..8678c6269 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux @@ -0,0 +1,307 @@ +(.module: + [library + [lux (#- Type Definition) + ["." host] + [abstract + ["." monad (#+ do)]] + [control + [pipe (#+ case>)] + ["<>" parser ("#\." monad) + ["<c>" code (#+ Parser)] + ["<t>" text]]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." dictionary] + ["." row]]] + [macro + ["." template]] + [math + [number + ["." i32]]] + [target + [jvm + ["_" bytecode (#+ Bytecode)] + ["." modifier (#+ Modifier) ("#\." monoid)] + ["." attribute] + ["." field] + ["." version] + ["." class] + ["." constant + ["." pool (#+ Resource)]] + [encoding + ["." name]] + ["." type (#+ Type Constraint Argument Typed) + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] + [".T" lux (#+ Mapping)] + ["." signature] + ["." descriptor (#+ Descriptor)] + ["." parser]]]] + [tool + [compiler + ["." analysis] + ["." synthesis] + ["." generation] + ["." directive (#+ Handler Bundle)] + ["." phase + [analysis + [".A" type]] + ["." generation + [jvm + [runtime (#+ Anchor Definition)]]] + ["." extension + ["." bundle] + [analysis + ["." jvm]] + [directive + ["/" lux]]]]]] + [type + ["." check (#+ Check)]]]]) + +(type: Operation + (directive.Operation Anchor (Bytecode Any) Definition)) + +(def: signature (|>> type.signature signature.signature)) + +(type: Declaration + [Text (List (Type Var))]) + +(def: declaration + (Parser Declaration) + (<c>.form (<>.and <c>.text (<>.some jvm.var)))) + +(def: visibility + (Parser (Modifier field.Field)) + (`` ($_ <>.either + (~~ (template [<label> <modifier>] + [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))] + + ["public" field.public] + ["private" field.private] + ["protected" field.protected] + ["default" modifier.empty]))))) + +(def: inheritance + (Parser (Modifier class.Class)) + (`` ($_ <>.either + (~~ (template [<label> <modifier>] + [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))] + + ["final" class.final] + ["abstract" class.abstract] + ["default" modifier.empty]))))) + +(def: state + (Parser (Modifier field.Field)) + (`` ($_ <>.either + (~~ (template [<label> <modifier>] + [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))] + + ["volatile" field.volatile] + ["final" field.final] + ["default" modifier.empty]))))) + +(type: Annotation Any) + +(def: annotation + (Parser Annotation) + <c>.any) + +(def: field-type + (Parser (Type Value)) + (<t>.embed parser.value <c>.text)) + +(type: Constant + [Text (List Annotation) (Type Value) Code]) + +(def: constant + (Parser Constant) + (<| <c>.form + (<>.after (<c>.text! "constant")) + ($_ <>.and + <c>.text + (<c>.tuple (<>.some ..annotation)) + ..field-type + <c>.any + ))) + +(type: Variable + [Text (Modifier field.Field) (Modifier field.Field) (List Annotation) (Type Value)]) + +(def: variable + (Parser Variable) + (<| <c>.form + (<>.after (<c>.text! "variable")) + ($_ <>.and + <c>.text + ..visibility + ..state + (<c>.tuple (<>.some ..annotation)) + ..field-type + ))) + +(type: Field + (#Constant Constant) + (#Variable Variable)) + +(def: field + (Parser Field) + ($_ <>.or + ..constant + ..variable + )) + +(type: Method-Definition + (#Constructor (jvm.Constructor Code)) + (#Virtual-Method (jvm.Virtual-Method Code)) + (#Static-Method (jvm.Static-Method Code)) + (#Overriden-Method (jvm.Overriden-Method Code))) + +(def: method + (Parser Method-Definition) + ($_ <>.or + jvm.constructor-definition + jvm.virtual-method-definition + jvm.static-method-definition + jvm.overriden-method-definition + )) + +(def: (constraint name) + (-> Text Constraint) + {#type.name name + #type.super-class (type.class "java.lang.Object" (list)) + #type.super-interfaces (list)}) + +(def: constant::modifier + (Modifier field.Field) + ($_ modifier\compose + field.public + field.static + field.final)) + +(def: (field-definition field) + (-> Field (Resource field.Field)) + (case field + ## TODO: Handle annotations. + (#Constant [name annotations type value]) + (case value + (^template [<tag> <type> <constant>] + [[_ (<tag> value)] + (do pool.monad + [constant (`` (|> value (~~ (template.splice <constant>)))) + attribute (attribute.constant constant)] + (field.field ..constant::modifier name <type> (row.row attribute)))]) + ([#.Bit type.boolean [(case> #0 +0 #1 +1) .i64 i32.i32 constant.integer pool.integer]] + [#.Int type.byte [.i64 i32.i32 constant.integer pool.integer]] + [#.Int type.short [.i64 i32.i32 constant.integer pool.integer]] + [#.Int type.int [.i64 i32.i32 constant.integer pool.integer]] + [#.Int type.long [constant.long pool.long]] + [#.Frac type.float [host.double-to-float constant.float pool.float]] + [#.Frac type.double [constant.double pool.double]] + [#.Nat type.char [.i64 i32.i32 constant.integer pool.integer]] + [#.Text (type.class "java.lang.String" (list)) [pool.string]] + ) + + ## TODO: Tighten this pattern-matching so this catch-all clause isn't necessary. + _ + (undefined)) + + ## TODO: Handle annotations. + (#Variable [name visibility state annotations type]) + (field.field (modifier\compose visibility state) + name type (row.row)))) + +(def: (method-definition [mapping selfT] [analyse synthesize generate]) + (-> [Mapping .Type] + [analysis.Phase + synthesis.Phase + (generation.Phase Anchor (Bytecode Any) Definition)] + (-> Method-Definition (Operation synthesis.Synthesis))) + (function (_ methodC) + (do phase.monad + [methodA (: (Operation analysis.Analysis) + (directive.lift-analysis + (case methodC + (#Constructor method) + (jvm.analyse-constructor-method analyse selfT mapping method) + + (#Virtual-Method method) + (jvm.analyse-virtual-method analyse selfT mapping method) + + (#Static-Method method) + (jvm.analyse-static-method analyse mapping method) + + (#Overriden-Method method) + (jvm.analyse-overriden-method analyse selfT mapping method))))] + (directive.lift-synthesis + (synthesize methodA))))) + +(def: jvm::class + (Handler Anchor (Bytecode Any) Definition) + (/.custom + [($_ <>.and + ..declaration + jvm.class + (<c>.tuple (<>.some jvm.class)) + ..inheritance + (<c>.tuple (<>.some ..annotation)) + (<c>.tuple (<>.some ..field)) + (<c>.tuple (<>.some ..method))) + (function (_ extension phase + [[name parameters] + super-class + super-interfaces + inheritance + ## TODO: Handle annotations. + annotations + fields + methods]) + (do {! phase.monad} + [parameters (directive.lift-analysis + (typeA.with-env + (jvm.parameter-types parameters))) + #let [mapping (list\fold (function (_ [parameterJ parameterT] mapping) + (dictionary.put (parser.name parameterJ) parameterT mapping)) + luxT.fresh + parameters)] + super-classT (directive.lift-analysis + (typeA.with-env + (luxT.check (luxT.class mapping) (..signature super-class)))) + super-interfaceT+ (directive.lift-analysis + (typeA.with-env + (monad.map check.monad + (|>> ..signature (luxT.check (luxT.class mapping))) + super-interfaces))) + #let [selfT (jvm.inheritance-relationship-type (#.Primitive name (list\map product.right parameters)) + super-classT + super-interfaceT+)] + state (extension.lift phase.get-state) + #let [analyse (get@ [#directive.analysis #directive.phase] state) + synthesize (get@ [#directive.synthesis #directive.phase] state) + generate (get@ [#directive.generation #directive.phase] state)] + methods (monad.map ! (..method-definition [mapping selfT] [analyse synthesize generate]) + methods) + ## _ (directive.lift-generation + ## (generation.save! true ["" name] + ## [name + ## (class.class version.v6_0 + ## (modifier\compose class.public inheritance) + ## (name.internal name) (list\map (|>> product.left parser.name ..constraint) parameters) + ## super-class super-interfaces + ## (list\map ..field-definition fields) + ## (list) ## TODO: Add methods + ## (row.row))])) + _ (directive.lift-generation + (generation.log! (format "Class " name)))] + (wrap directive.no-requirements)))])) + +(def: #export bundle + (Bundle Anchor (Bytecode Any) Definition) + (<| (bundle.prefix "jvm") + (|> bundle.empty + ## TODO: Finish handling methods and un-comment. + ## (dictionary.put "class" jvm::class) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux new file mode 100644 index 000000000..dc8272030 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux @@ -0,0 +1,451 @@ +(.module: + [library + [lux #* + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + [io (#+ IO)] + ["." try] + ["." exception (#+ exception:)] + ["p" parser + ["s" code (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary]]] + [macro + ["." code]] + [math + [number + ["n" nat]]] + ["." type (#+ :share) + ["." check]]]] + ["." /// (#+ Extender) + ["#." bundle] + ["#." analysis] + ["/#" // #_ + [analysis + ["." module] + [".A" type]] + ["/#" // #_ + ["#." analysis + [macro (#+ Expander)] + ["#/." evaluation]] + ["#." synthesis (#+ Synthesis)] + ["#." generation (#+ Context)] + ["#." directive (#+ Import Requirements Phase Operation Handler Bundle)] + ["#." program (#+ Program)] + [/// + ["." phase] + [meta + ["." archive (#+ Archive)]]]]]]) + +(def: #export (custom [syntax handler]) + (All [anchor expression directive s] + (-> [(Parser s) + (-> Text + (Phase anchor expression directive) + Archive + s + (Operation anchor expression directive Requirements))] + (Handler anchor expression directive))) + (function (_ extension_name phase archive inputs) + (case (s.run syntax inputs) + (#try.Success inputs) + (handler extension_name phase archive inputs) + + (#try.Failure error) + (phase.throw ///.invalid_syntax [extension_name %.code inputs])))) + +(def: (context [module_id artifact_id]) + (-> Context Context) + ## TODO: Find a better way that doesn't rely on clever tricks. + [module_id (n.- (inc artifact_id) 0)]) + +## TODO: Inline "evaluate!'" into "evaluate!" ASAP +(def: (evaluate!' archive generate code//type codeS) + (All [anchor expression directive] + (-> Archive + (/////generation.Phase anchor expression directive) + Type + Synthesis + (Operation anchor expression directive [Type expression Any]))) + (/////directive.lift_generation + (do phase.monad + [module /////generation.module + id /////generation.next + codeG (generate archive codeS) + module_id (/////generation.module_id module archive) + codeV (/////generation.evaluate! (..context [module_id id]) codeG)] + (wrap [code//type codeG codeV])))) + +(def: #export (evaluate! archive type codeC) + (All [anchor expression directive] + (-> Archive Type Code (Operation anchor expression directive [Type expression Any]))) + (do phase.monad + [state (///.lift phase.get_state) + #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state) + synthesize (get@ [#/////directive.synthesis #/////directive.phase] state) + generate (get@ [#/////directive.generation #/////directive.phase] state)] + [_ codeA] (/////directive.lift_analysis + (/////analysis.with_scope + (typeA.with_fresh_env + (typeA.with_type type + (analyse archive codeC))))) + codeS (/////directive.lift_synthesis + (synthesize archive codeA))] + (evaluate!' archive generate type codeS))) + +## TODO: Inline "definition'" into "definition" ASAP +(def: (definition' archive generate [module name] code//type codeS) + (All [anchor expression directive] + (-> Archive + (/////generation.Phase anchor expression directive) + Name + Type + Synthesis + (Operation anchor expression directive [Type expression Any]))) + (/////directive.lift_generation + (do phase.monad + [codeG (generate archive codeS) + id (/////generation.learn name) + module_id (phase.lift (archive.id module archive)) + [target_name value directive] (/////generation.define! [module_id id] codeG) + _ (/////generation.save! id directive)] + (wrap [code//type codeG value])))) + +(def: (definition archive name expected codeC) + (All [anchor expression directive] + (-> Archive Name (Maybe Type) Code + (Operation anchor expression directive [Type expression Any]))) + (do {! phase.monad} + [state (///.lift phase.get_state) + #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state) + synthesize (get@ [#/////directive.synthesis #/////directive.phase] state) + generate (get@ [#/////directive.generation #/////directive.phase] state)] + [_ code//type codeA] (/////directive.lift_analysis + (/////analysis.with_scope + (typeA.with_fresh_env + (case expected + #.None + (do ! + [[code//type codeA] (typeA.with_inference + (analyse archive codeC)) + code//type (typeA.with_env + (check.clean code//type))] + (wrap [code//type codeA])) + + (#.Some expected) + (do ! + [codeA (typeA.with_type expected + (analyse archive codeC))] + (wrap [expected codeA])))))) + codeS (/////directive.lift_synthesis + (synthesize archive codeA))] + (definition' archive generate name code//type codeS))) + +(template [<full> <partial> <learn>] + [## TODO: Inline "<partial>" into "<full>" ASAP + (def: (<partial> archive generate extension codeT codeS) + (All [anchor expression directive] + (-> Archive + (/////generation.Phase anchor expression directive) + Text + Type + Synthesis + (Operation anchor expression directive [expression Any]))) + (do phase.monad + [current_module (/////directive.lift_analysis + (///.lift meta.current_module_name))] + (/////directive.lift_generation + (do phase.monad + [codeG (generate archive codeS) + module_id (phase.lift (archive.id current_module archive)) + id (<learn> extension) + [target_name value directive] (/////generation.define! [module_id id] codeG) + _ (/////generation.save! id directive)] + (wrap [codeG value]))))) + + (def: #export (<full> archive extension codeT codeC) + (All [anchor expression directive] + (-> Archive Text Type Code + (Operation anchor expression directive [expression Any]))) + (do phase.monad + [state (///.lift phase.get_state) + #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state) + synthesize (get@ [#/////directive.synthesis #/////directive.phase] state) + generate (get@ [#/////directive.generation #/////directive.phase] state)] + [_ codeA] (/////directive.lift_analysis + (/////analysis.with_scope + (typeA.with_fresh_env + (typeA.with_type codeT + (analyse archive codeC))))) + codeS (/////directive.lift_synthesis + (synthesize archive codeA))] + (<partial> archive generate extension codeT codeS)))] + + [analyser analyser' /////generation.learn_analyser] + [synthesizer synthesizer' /////generation.learn_synthesizer] + [generator generator' /////generation.learn_generator] + [directive directive' /////generation.learn_directive] + ) + +(def: (refresh expander host_analysis) + (All [anchor expression directive] + (-> Expander /////analysis.Bundle (Operation anchor expression directive Any))) + (do phase.monad + [[bundle state] phase.get_state + #let [eval (/////analysis/evaluation.evaluator expander + (get@ [#/////directive.synthesis #/////directive.state] state) + (get@ [#/////directive.generation #/////directive.state] state) + (get@ [#/////directive.generation #/////directive.phase] state))]] + (phase.set_state [bundle + (update@ [#/////directive.analysis #/////directive.state] + (: (-> /////analysis.State+ /////analysis.State+) + (|>> product.right + [(///analysis.bundle eval host_analysis)])) + state)]))) + +(def: (announce_definition! short type) + (All [anchor expression directive] + (-> Text Type (Operation anchor expression directive Any))) + (/////directive.lift_generation + (/////generation.log! (format short " : " (%.type type))))) + +(def: (lux::def expander host_analysis) + (-> Expander /////analysis.Bundle Handler) + (function (_ extension_name phase archive inputsC+) + (case inputsC+ + (^ (list [_ (#.Identifier ["" short_name])] valueC annotationsC [_ (#.Bit exported?)])) + (do phase.monad + [current_module (/////directive.lift_analysis + (///.lift meta.current_module_name)) + #let [full_name [current_module short_name]] + [type valueT value] (..definition archive full_name #.None valueC) + [_ annotationsT annotations] (evaluate! archive Code annotationsC) + _ (/////directive.lift_analysis + (module.define short_name (#.Right [exported? type (:as Code annotations) value]))) + _ (..refresh expander host_analysis) + _ (..announce_definition! short_name type)] + (wrap /////directive.no_requirements)) + + _ + (phase.throw ///.invalid_syntax [extension_name %.code inputsC+])))) + +(def: (def::type_tagged expander host_analysis) + (-> Expander /////analysis.Bundle Handler) + (..custom + [($_ p.and s.local_identifier s.any s.any (s.tuple (p.some s.text)) s.bit) + (function (_ extension_name phase archive [short_name valueC annotationsC tags exported?]) + (do phase.monad + [current_module (/////directive.lift_analysis + (///.lift meta.current_module_name)) + #let [full_name [current_module short_name]] + [_ annotationsT annotations] (evaluate! archive Code annotationsC) + #let [annotations (:as Code annotations)] + [type valueT value] (..definition archive full_name (#.Some .Type) valueC) + _ (/////directive.lift_analysis + (do phase.monad + [_ (module.define short_name (#.Right [exported? type annotations value]))] + (module.declare_tags tags exported? (:as Type value)))) + _ (..refresh expander host_analysis) + _ (..announce_definition! short_name type)] + (wrap /////directive.no_requirements)))])) + +(def: imports + (Parser (List Import)) + (|> (s.tuple (p.and s.text s.text)) + p.some + s.tuple)) + +(def: def::module + Handler + (..custom + [($_ p.and s.any ..imports) + (function (_ extension_name phase archive [annotationsC imports]) + (do {! phase.monad} + [[_ annotationsT annotationsV] (evaluate! archive Code annotationsC) + #let [annotationsV (:as Code annotationsV)] + _ (/////directive.lift_analysis + (do ! + [_ (monad.map ! (function (_ [module alias]) + (do ! + [_ (module.import module)] + (case alias + "" (wrap []) + _ (module.alias alias module)))) + imports)] + (module.set_annotations annotationsV)))] + (wrap {#/////directive.imports imports + #/////directive.referrals (list)})))])) + +(exception: #export (cannot_alias_an_alias {local Alias} {foreign Alias} {target Name}) + (exception.report + ["Local alias" (%.name local)] + ["Foreign alias" (%.name foreign)] + ["Target definition" (%.name target)])) + +(def: (define_alias alias original) + (-> Text Name (/////analysis.Operation Any)) + (do phase.monad + [current_module (///.lift meta.current_module_name) + constant (///.lift (meta.find_def original))] + (case constant + (#.Left de_aliased) + (phase.throw ..cannot_alias_an_alias [[current_module alias] original de_aliased]) + + (#.Right [exported? original_type original_annotations original_value]) + (module.define alias (#.Left original))))) + +(def: def::alias + Handler + (..custom + [($_ p.and s.local_identifier s.identifier) + (function (_ extension_name phase archive [alias def_name]) + (do phase.monad + [_ (///.lift + (phase.sub [(get@ [#/////directive.analysis #/////directive.state]) + (set@ [#/////directive.analysis #/////directive.state])] + (define_alias alias def_name)))] + (wrap /////directive.no_requirements)))])) + +(template [<description> <mame> <def_type> <type> <scope> <definer>] + [(def: (<mame> [anchorT expressionT directiveT] extender) + (All [anchor expression directive] + (-> [Type Type Type] Extender + (Handler anchor expression directive))) + (function (handler extension_name phase archive inputsC+) + (case inputsC+ + (^ (list nameC valueC)) + (do phase.monad + [[_ _ name] (evaluate! archive Text nameC) + [_ handlerV] (<definer> archive (:as Text name) + (type <def_type>) + valueC) + _ (<| <scope> + (///.install extender (:as Text name)) + (:share [anchor expression directive] + (Handler anchor expression directive) + handler + + <type> + (:assume handlerV))) + _ (/////directive.lift_generation + (/////generation.log! (format <description> " " (%.text (:as Text name)))))] + (wrap /////directive.no_requirements)) + + _ + (phase.throw ///.invalid_syntax [extension_name %.code inputsC+]))))] + + ["Analysis" + def::analysis + /////analysis.Handler /////analysis.Handler + /////directive.lift_analysis + ..analyser] + ["Synthesis" + def::synthesis + /////synthesis.Handler /////synthesis.Handler + /////directive.lift_synthesis + ..synthesizer] + ["Generation" + def::generation + (/////generation.Handler anchorT expressionT directiveT) (/////generation.Handler anchor expression directive) + /////directive.lift_generation + ..generator] + ["Directive" + def::directive + (/////directive.Handler anchorT expressionT directiveT) (/////directive.Handler anchor expression directive) + (<|) + ..directive] + ) + +## TODO; Both "prepare-program" and "define-program" exist only +## because the old compiler couldn't handle a fully-inlined definition +## for "def::program". Inline them ASAP. +(def: (prepare_program archive analyse synthesize programC) + (All [anchor expression directive output] + (-> Archive + /////analysis.Phase + /////synthesis.Phase + Code + (Operation anchor expression directive Synthesis))) + (do phase.monad + [[_ programA] (/////directive.lift_analysis + (/////analysis.with_scope + (typeA.with_fresh_env + (typeA.with_type (type (-> (List Text) (IO Any))) + (analyse archive programC)))))] + (/////directive.lift_synthesis + (synthesize archive programA)))) + +(def: (define_program archive module_id generate program programS) + (All [anchor expression directive output] + (-> Archive + archive.ID + (/////generation.Phase anchor expression directive) + (Program expression directive) + Synthesis + (/////generation.Operation anchor expression directive Any))) + (do phase.monad + [programG (generate archive programS) + artifact_id (/////generation.learn /////program.name)] + (/////generation.save! artifact_id (program [module_id artifact_id] programG)))) + +(def: (def::program program) + (All [anchor expression directive] + (-> (Program expression directive) (Handler anchor expression directive))) + (function (handler extension_name phase archive inputsC+) + (case inputsC+ + (^ (list programC)) + (do phase.monad + [state (///.lift phase.get_state) + #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state) + synthesize (get@ [#/////directive.synthesis #/////directive.phase] state) + generate (get@ [#/////directive.generation #/////directive.phase] state)] + programS (prepare_program archive analyse synthesize programC) + current_module (/////directive.lift_analysis + (///.lift meta.current_module_name)) + module_id (phase.lift (archive.id current_module archive)) + _ (/////directive.lift_generation + (define_program archive module_id generate program programS))] + (wrap /////directive.no_requirements)) + + _ + (phase.throw ///.invalid_syntax [extension_name %.code inputsC+])))) + +(def: (bundle::def expander host_analysis program anchorT,expressionT,directiveT extender) + (All [anchor expression directive] + (-> Expander + /////analysis.Bundle + (Program expression directive) + [Type Type Type] + Extender + (Bundle anchor expression directive))) + (<| (///bundle.prefix "def") + (|> ///bundle.empty + (dictionary.put "module" def::module) + (dictionary.put "alias" def::alias) + (dictionary.put "type tagged" (def::type_tagged expander host_analysis)) + (dictionary.put "analysis" (def::analysis anchorT,expressionT,directiveT extender)) + (dictionary.put "synthesis" (def::synthesis anchorT,expressionT,directiveT extender)) + (dictionary.put "generation" (def::generation anchorT,expressionT,directiveT extender)) + (dictionary.put "directive" (def::directive anchorT,expressionT,directiveT extender)) + (dictionary.put "program" (def::program program)) + ))) + +(def: #export (bundle expander host_analysis program anchorT,expressionT,directiveT extender) + (All [anchor expression directive] + (-> Expander + /////analysis.Bundle + (Program expression directive) + [Type Type Type] + Extender + (Bundle anchor expression directive))) + (<| (///bundle.prefix "lux") + (|> ///bundle.empty + (dictionary.put "def" (lux::def expander host_analysis)) + (dictionary.merge (..bundle::def expander host_analysis program anchorT,expressionT,directiveT extender))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux new file mode 100644 index 000000000..f42aa31ff --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux @@ -0,0 +1,18 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [common_lisp + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux new file mode 100644 index 000000000..7f911e3b3 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux @@ -0,0 +1,180 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary] + ["." set] + ["." list ("#\." functor fold)]]] + [math + [number + ["f" frac]]] + ["@" target + ["_" common_lisp (#+ Expression)]]]] + ["." //// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" common_lisp #_ + ["#." runtime (#+ Operation Phase Handler Bundle Generator)] + ["#." case]]] + [// + ["." synthesis (#+ %synthesis)] + ["." generation] + [/// + ["#" phase]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension_name phase archive input') + + (#try.Failure error) + (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) + +(template: (!unary function) + (|>> list _.apply/* (|> (_.constant function)))) + +## ## TODO: Get rid of this ASAP +## (def: lux::syntax_char_case! +## (..custom [($_ <>.and +## <s>.any +## <s>.any +## (<>.some (<s>.tuple ($_ <>.and +## (<s>.tuple (<>.many <s>.i64)) +## <s>.any)))) +## (function (_ extension_name phase archive [input else conditionals]) +## (do {! /////.monad} +## [@input (\ ! map _.var (generation.gensym "input")) +## inputG (phase archive input) +## elseG (phase archive else) +## conditionalsG (: (Operation (List [Expression Expression])) +## (monad.map ! (function (_ [chars branch]) +## (do ! +## [branchG (phase archive branch)] +## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or) +## branchG]))) +## conditionals))] +## (wrap (_.let (list [@input inputG]) +## (list (list\fold (function (_ [test then] else) +## (_.if test then else)) +## elseG +## conditionalsG))))))])) + +(def: lux_procs + Bundle + (|> /.empty + ## (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary _.eq/2)) + ## (/.install "try" (unary //runtime.lux//try)) + )) + +## (def: (capped operation parameter subject) +## (-> (-> Expression Expression Expression) +## (-> Expression Expression Expression)) +## (//runtime.i64//64 (operation parameter subject))) + +(def: i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary _.logand/2)) + (/.install "or" (binary _.logior/2)) + (/.install "xor" (binary _.logxor/2)) + (/.install "left-shift" (binary _.ash/2)) + (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) + (/.install "=" (binary _.=/2)) + (/.install "<" (binary _.</2)) + (/.install "+" (binary _.+/2)) + (/.install "-" (binary _.-/2)) + (/.install "*" (binary _.*/2)) + (/.install "/" (binary _.floor/2)) + (/.install "%" (binary _.rem/2)) + ## (/.install "f64" (unary (_.//2 (_.float +1.0)))) + (/.install "char" (unary (|>> _.code-char/1 _.string/1))) + ))) + +(def: f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + ## (/.install "=" (binary (product.uncurry _.=/2))) + ## (/.install "<" (binary (product.uncurry _.</2))) + ## (/.install "+" (binary (product.uncurry _.+/2))) + ## (/.install "-" (binary (product.uncurry _.-/2))) + ## (/.install "*" (binary (product.uncurry _.*/2))) + ## (/.install "/" (binary (product.uncurry _.//2))) + ## (/.install "%" (binary (product.uncurry _.rem/2))) + ## (/.install "i64" (unary _.truncate/1)) + (/.install "encode" (unary _.write-to-string/1)) + ## (/.install "decode" (unary //runtime.f64//decode)) + ))) + +(def: (text//index [offset sub text]) + (Trinary (Expression Any)) + (//runtime.text//index offset sub text)) + +(def: (text//clip [offset length text]) + (Trinary (Expression Any)) + (//runtime.text//clip offset length text)) + +(def: (text//char [index text]) + (Binary (Expression Any)) + (_.char-code/1 (_.char/2 [text index]))) + +(def: text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary _.string=/2)) + ## (/.install "<" (binary (product.uncurry _.string<?/2))) + (/.install "concat" (binary (function (_ [left right]) + (_.concatenate/3 [(_.symbol "string") left right])))) + (/.install "index" (trinary ..text//index)) + (/.install "size" (unary _.length/1)) + (/.install "char" (binary ..text//char)) + (/.install "clip" (trinary ..text//clip)) + ))) + +(def: (io//log! message) + (Unary (Expression Any)) + (_.progn (list (_.write-line/1 message) + //runtime.unit))) + +(def: io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary ..io//log!)) + (/.install "error" (unary _.error/1)) + ))) + +(def: #export bundle + Bundle + (<| (/.prefix "lux") + (|> /.empty + (dictionary.merge lux_procs) + (dictionary.merge i64_procs) + (dictionary.merge f64_procs) + (dictionary.merge text_procs) + (dictionary.merge io_procs) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux new file mode 100644 index 000000000..9895f051a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux @@ -0,0 +1,40 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + [collection + ["." dictionary] + ["." list]] + [text + ["%" format (#+ format)]]] + [target + ["_" common_lisp (#+ Var Expression)]]]] + ["." // #_ + ["#." common (#+ custom)] + ["//#" /// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" common_lisp #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with_vars)]]] + ["/#" // #_ + ["." generation] + ["//#" /// #_ + ["#." phase]]]]]]) + +(def: #export bundle + Bundle + (<| (/.prefix "common_lisp") + (|> /.empty + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js.lux new file mode 100644 index 000000000..ba83e257f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js.lux @@ -0,0 +1,18 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [js + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux new file mode 100644 index 000000000..a74c72d38 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux @@ -0,0 +1,191 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + [collection + ["." list ("#\." functor)] + ["." dictionary]]] + [math + [number + ["f" frac]]] + ["@" target + ["_" js (#+ Literal Expression Statement)]]]] + ["." //// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" js #_ + ["#." runtime (#+ Operation Phase Handler Bundle Generator)] + ["#." primitive]]] + [// + [synthesis (#+ %synthesis)] + [/// + ["#" phase]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension_name phase archive input') + + (#try.Failure error) + (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) + +## [Procedures] +## [[Bits]] +(template [<name> <op>] + [(def: (<name> [paramG subjectG]) + (Binary Expression) + (<op> subjectG (//runtime.i64//to_number paramG)))] + + [i64//left_shift //runtime.i64//left_shift] + [i64//right_shift //runtime.i64//right_shift] + ) + +## [[Numbers]] +(def: f64//decode + (Unary Expression) + (|>> list + (_.apply/* (_.var "parseFloat")) + _.return + (_.closure (list)) + //runtime.lux//try)) + +(def: i64//char + (Unary Expression) + (|>> //runtime.i64//to_number + (list) + (_.apply/* (_.var "String.fromCharCode")))) + +## [[Text]] +(def: (text//concat [leftG rightG]) + (Binary Expression) + (|> leftG (_.do "concat" (list rightG)))) + +(def: (text//clip [startG endG subjectG]) + (Trinary Expression) + (//runtime.text//clip startG endG subjectG)) + +(def: (text//index [startG partG subjectG]) + (Trinary Expression) + (//runtime.text//index startG partG subjectG)) + +## [[IO]] +(def: (io//log messageG) + (Unary Expression) + ($_ _., + (//runtime.io//log messageG) + //runtime.unit)) + +## TODO: Get rid of this ASAP +(def: lux::syntax_char_case! + (..custom [($_ <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple ($_ <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension_name phase archive [input else conditionals]) + (do {! /////.monad} + [inputG (phase archive input) + elseG (phase archive else) + conditionalsG (: (Operation (List [(List Literal) + Statement])) + (monad.map ! (function (_ [chars branch]) + (do ! + [branchG (phase archive branch)] + (wrap [(list\map (|>> .int _.int) chars) + (_.return branchG)]))) + conditionals))] + (wrap (_.apply/* (_.closure (list) + (_.switch (_.the //runtime.i64_low_field inputG) + conditionalsG + (#.Some (_.return elseG)))) + (list)))))])) + +## [Bundles] +(def: lux_procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (product.uncurry _.=))) + (/.install "try" (unary //runtime.lux//try)))) + +(def: i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurry //runtime.i64//and))) + (/.install "or" (binary (product.uncurry //runtime.i64//or))) + (/.install "xor" (binary (product.uncurry //runtime.i64//xor))) + (/.install "left-shift" (binary i64//left_shift)) + (/.install "right-shift" (binary i64//right_shift)) + (/.install "=" (binary (product.uncurry //runtime.i64//=))) + (/.install "<" (binary (product.uncurry //runtime.i64//<))) + (/.install "+" (binary (product.uncurry //runtime.i64//+))) + (/.install "-" (binary (product.uncurry //runtime.i64//-))) + (/.install "*" (binary (product.uncurry //runtime.i64//*))) + (/.install "/" (binary (product.uncurry //runtime.i64///))) + (/.install "%" (binary (product.uncurry //runtime.i64//%))) + (/.install "f64" (unary //runtime.i64//to_number)) + (/.install "char" (unary i64//char)) + ))) + +(def: f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "+" (binary (product.uncurry _.+))) + (/.install "-" (binary (product.uncurry _.-))) + (/.install "*" (binary (product.uncurry _.*))) + (/.install "/" (binary (product.uncurry _./))) + (/.install "%" (binary (product.uncurry _.%))) + (/.install "=" (binary (product.uncurry _.=))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "i64" (unary //runtime.i64//from_number)) + (/.install "encode" (unary (_.do "toString" (list)))) + (/.install "decode" (unary f64//decode))))) + +(def: text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurry _.=))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "concat" (binary text//concat)) + (/.install "index" (trinary text//index)) + (/.install "size" (unary (|>> (_.the "length") //runtime.i64//from_number))) + (/.install "char" (binary (product.uncurry //runtime.text//char))) + (/.install "clip" (trinary text//clip)) + ))) + +(def: io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary io//log)) + (/.install "error" (unary //runtime.io//error))))) + +(def: #export bundle + Bundle + (<| (/.prefix "lux") + (|> lux_procs + (dictionary.merge i64_procs) + (dictionary.merge f64_procs) + (dictionary.merge text_procs) + (dictionary.merge io_procs) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux new file mode 100644 index 000000000..edc4e2321 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux @@ -0,0 +1,160 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + [collection + ["." dictionary] + ["." list]]] + [target + ["_" js (#+ Var Expression)]]]] + ["." // #_ + ["#." common (#+ custom)] + ["//#" /// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" js #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with_vars)]]] + ["/#" // #_ + ["." generation] + ["//#" /// #_ + ["#." phase]]]]]]) + +(def: array::new + (Unary Expression) + (|>> (_.the //runtime.i64_low_field) list (_.new (_.var "Array")))) + +(def: array::length + (Unary Expression) + (|>> (_.the "length") //runtime.i64//from_number)) + +(def: (array::read [indexG arrayG]) + (Binary Expression) + (_.at (_.the //runtime.i64_low_field indexG) + arrayG)) + +(def: (array::write [indexG valueG arrayG]) + (Trinary Expression) + (//runtime.array//write indexG valueG arrayG)) + +(def: (array::delete [indexG arrayG]) + (Binary Expression) + (//runtime.array//delete indexG arrayG)) + +(def: array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary array::length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(def: object::new + (custom + [($_ <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [constructorS inputsS]) + (do {! ////////phase.monad} + [constructorG (phase archive constructorS) + inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.new constructorG inputsG))))])) + +(def: object::get + Handler + (custom + [($_ <>.and <s>.text <s>.any) + (function (_ extension phase archive [fieldS objectS]) + (do ////////phase.monad + [objectG (phase archive objectS)] + (wrap (_.the fieldS objectG))))])) + +(def: object::do + Handler + (custom + [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [methodS objectS inputsS]) + (do {! ////////phase.monad} + [objectG (phase archive objectS) + inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.do methodS inputsG objectG))))])) + +(template [<!> <?> <unit>] + [(def: <!> (Nullary Expression) (function.constant <unit>)) + (def: <?> (Unary Expression) (_.= <unit>))] + + [object::null object::null? _.null] + [object::undefined object::undefined? _.undefined] + ) + +(def: object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "new" object::new) + (/.install "get" object::get) + (/.install "do" object::do) + (/.install "null" (nullary object::null)) + (/.install "null?" (unary object::null?)) + (/.install "undefined" (nullary object::undefined)) + (/.install "undefined?" (unary object::undefined?)) + ))) + +(def: js::constant + (custom + [<s>.text + (function (_ extension phase archive name) + (\ ////////phase.monad wrap (_.var name)))])) + +(def: js::apply + (custom + [($_ <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [abstractionS inputsS]) + (do {! ////////phase.monad} + [abstractionG (phase archive abstractionS) + inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.apply/* abstractionG inputsG))))])) + +(def: js::function + (custom + [($_ <>.and <s>.i64 <s>.any) + (function (_ extension phase archive [arity abstractionS]) + (do {! ////////phase.monad} + [abstractionG (phase archive abstractionS) + #let [variable (: (-> Text (Operation Var)) + (|>> generation.gensym + (\ ! map _.var)))] + g!inputs (monad.map ! (function (_ _) (variable "input")) + (list.repeat (.nat arity) [])) + g!abstraction (variable "abstraction")] + (wrap (_.closure g!inputs + ($_ _.then + (_.define g!abstraction abstractionG) + (_.return (case (.nat arity) + 0 (_.apply/1 g!abstraction //runtime.unit) + 1 (_.apply/* g!abstraction g!inputs) + _ (_.apply/1 g!abstraction (_.array g!inputs)))))))))])) + +(def: #export bundle + Bundle + (<| (/.prefix "js") + (|> /.empty + (dictionary.merge ..array) + (dictionary.merge ..object) + + (/.install "constant" js::constant) + (/.install "apply" js::apply) + (/.install "type-of" (unary _.type_of)) + (/.install "function" js::function) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux new file mode 100644 index 000000000..396c3284e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux @@ -0,0 +1,20 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [jvm + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + ($_ dictionary.merge + /common.bundle + /host.bundle + )) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux new file mode 100644 index 000000000..da55a6c32 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux @@ -0,0 +1,414 @@ +(.module: + [library + [lux (#- Type) + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["." exception (#+ exception:)] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + [number + ["." i32] + ["f" frac]] + [collection + ["." list ("#\." monad)] + ["." dictionary]]] + [target + [jvm + ["_" bytecode (#+ Label Bytecode) ("#\." monad)] + [encoding + ["." signed (#+ S4)]] + ["." type (#+ Type) + [category (#+ Primitive Class)]]]]]] + ["." ///// #_ + [generation + [extension (#+ Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)] + ["///" jvm #_ + ["#." value] + ["#." runtime (#+ Operation Phase Bundle Handler)] + ["#." function #_ + ["#" abstract]]]] + [extension + ["#extension" /] + ["#." bundle]] + [// + ["/#." synthesis (#+ Synthesis %synthesis)] + [/// + ["#" phase] + [meta + [archive (#+ Archive)]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text Phase Archive s (Operation (Bytecode Any)))] + Handler)) + (function (_ extension-name phase archive input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension-name phase archive input') + + (#try.Failure error) + (/////.throw /////extension.invalid-syntax [extension-name //////synthesis.%synthesis input])))) + +(def: $Boolean (type.class "java.lang.Boolean" (list))) +(def: $Double (type.class "java.lang.Double" (list))) +(def: $Character (type.class "java.lang.Character" (list))) +(def: $String (type.class "java.lang.String" (list))) +(def: $CharSequence (type.class "java.lang.CharSequence" (list))) +(def: $Object (type.class "java.lang.Object" (list))) +(def: $PrintStream (type.class "java.io.PrintStream" (list))) +(def: $System (type.class "java.lang.System" (list))) +(def: $Error (type.class "java.lang.Error" (list))) + +(def: lux-int + (Bytecode Any) + ($_ _.compose + _.i2l + (///value.wrap type.long))) + +(def: jvm-int + (Bytecode Any) + ($_ _.compose + (///value.unwrap type.long) + _.l2i)) + +(def: ensure-string + (Bytecode Any) + (_.checkcast $String)) + +(def: (predicate bytecode) + (-> (-> Label (Bytecode Any)) + (Bytecode Any)) + (do _.monad + [@then _.new-label + @end _.new-label] + ($_ _.compose + (bytecode @then) + (_.getstatic $Boolean "FALSE" $Boolean) + (_.goto @end) + (_.set-label @then) + (_.getstatic $Boolean "TRUE" $Boolean) + (_.set-label @end) + ))) + +## TODO: Get rid of this ASAP +(def: lux::syntax-char-case! + (..custom [($_ <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple ($_ <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension-name phase archive [inputS elseS conditionalsS]) + (do {! /////.monad} + [@end ///runtime.forge-label + inputG (phase archive inputS) + elseG (phase archive elseS) + conditionalsG+ (: (Operation (List [(List [S4 Label]) + (Bytecode Any)])) + (monad.map ! (function (_ [chars branch]) + (do ! + [branchG (phase archive branch) + @branch ///runtime.forge-label] + (wrap [(list\map (function (_ char) + [(try.assume (signed.s4 (.int char))) @branch]) + chars) + ($_ _.compose + (_.set-label @branch) + branchG + (_.goto @end))]))) + conditionalsS)) + #let [table (|> conditionalsG+ + (list\map product.left) + list\join) + conditionalsG (|> conditionalsG+ + (list\map product.right) + (monad.seq _.monad))]] + (wrap (do _.monad + [@else _.new-label] + ($_ _.compose + inputG (///value.unwrap type.long) _.l2i + (_.lookupswitch @else table) + conditionalsG + (_.set-label @else) + elseG + (_.set-label @end) + )))))])) + +(def: (lux::is [referenceG sampleG]) + (Binary (Bytecode Any)) + ($_ _.compose + referenceG + sampleG + (..predicate _.if-acmpeq))) + +(def: (lux::try riskyG) + (Unary (Bytecode Any)) + ($_ _.compose + riskyG + (_.checkcast ///function.class) + ///runtime.try)) + +(def: bundle::lux + Bundle + (|> (: Bundle /////bundle.empty) + (/////bundle.install "syntax char case!" ..lux::syntax-char-case!) + (/////bundle.install "is" (binary ..lux::is)) + (/////bundle.install "try" (unary ..lux::try)))) + +(template [<name> <op>] + [(def: (<name> [maskG inputG]) + (Binary (Bytecode Any)) + ($_ _.compose + inputG (///value.unwrap type.long) + maskG (///value.unwrap type.long) + <op> (///value.wrap type.long)))] + + [i64::and _.land] + [i64::or _.lor] + [i64::xor _.lxor] + ) + +(template [<name> <op>] + [(def: (<name> [shiftG inputG]) + (Binary (Bytecode Any)) + ($_ _.compose + inputG (///value.unwrap type.long) + shiftG ..jvm-int + <op> (///value.wrap type.long)))] + + [i64::left-shift _.lshl] + [i64::right-shift _.lushr] + ) + +(template [<name> <type> <op>] + [(def: (<name> [paramG subjectG]) + (Binary (Bytecode Any)) + ($_ _.compose + subjectG (///value.unwrap <type>) + paramG (///value.unwrap <type>) + <op> (///value.wrap <type>)))] + + [i64::+ type.long _.ladd] + [i64::- type.long _.lsub] + [i64::* type.long _.lmul] + [i64::/ type.long _.ldiv] + [i64::% type.long _.lrem] + + [f64::+ type.double _.dadd] + [f64::- type.double _.dsub] + [f64::* type.double _.dmul] + [f64::/ type.double _.ddiv] + [f64::% type.double _.drem] + ) + +(template [<eq> <lt> <type> <cmp>] + [(template [<name> <reference>] + [(def: (<name> [paramG subjectG]) + (Binary (Bytecode Any)) + ($_ _.compose + subjectG (///value.unwrap <type>) + paramG (///value.unwrap <type>) + <cmp> + <reference> + (..predicate _.if-icmpeq)))] + + [<eq> _.iconst-0] + [<lt> _.iconst-m1])] + + [i64::= i64::< type.long _.lcmp] + [f64::= f64::< type.double _.dcmpg] + ) + +(def: (to-string class from) + (-> (Type Class) (Type Primitive) (Bytecode Any)) + (_.invokestatic class "toString" (type.method [(list from) ..$String (list)]))) + +(template [<name> <prepare> <transform>] + [(def: (<name> inputG) + (Unary (Bytecode Any)) + ($_ _.compose + inputG + <prepare> + <transform>))] + + [i64::f64 + (///value.unwrap type.long) + ($_ _.compose + _.l2d + (///value.wrap type.double))] + + [i64::char + (///value.unwrap type.long) + ($_ _.compose + _.l2i + _.i2c + (..to-string ..$Character type.char))] + + [f64::i64 + (///value.unwrap type.double) + ($_ _.compose + _.d2l + (///value.wrap type.long))] + + [f64::encode + (///value.unwrap type.double) + (..to-string ..$Double type.double)] + + [f64::decode + ..ensure-string + ///runtime.decode-frac] + ) + +(def: bundle::i64 + Bundle + (<| (/////bundle.prefix "i64") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "and" (binary ..i64::and)) + (/////bundle.install "or" (binary ..i64::or)) + (/////bundle.install "xor" (binary ..i64::xor)) + (/////bundle.install "left-shift" (binary ..i64::left-shift)) + (/////bundle.install "right-shift" (binary ..i64::right-shift)) + (/////bundle.install "=" (binary ..i64::=)) + (/////bundle.install "<" (binary ..i64::<)) + (/////bundle.install "+" (binary ..i64::+)) + (/////bundle.install "-" (binary ..i64::-)) + (/////bundle.install "*" (binary ..i64::*)) + (/////bundle.install "/" (binary ..i64::/)) + (/////bundle.install "%" (binary ..i64::%)) + (/////bundle.install "f64" (unary ..i64::f64)) + (/////bundle.install "char" (unary ..i64::char))))) + +(def: bundle::f64 + Bundle + (<| (/////bundle.prefix "f64") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "+" (binary ..f64::+)) + (/////bundle.install "-" (binary ..f64::-)) + (/////bundle.install "*" (binary ..f64::*)) + (/////bundle.install "/" (binary ..f64::/)) + (/////bundle.install "%" (binary ..f64::%)) + (/////bundle.install "=" (binary ..f64::=)) + (/////bundle.install "<" (binary ..f64::<)) + (/////bundle.install "i64" (unary ..f64::i64)) + (/////bundle.install "encode" (unary ..f64::encode)) + (/////bundle.install "decode" (unary ..f64::decode))))) + +(def: (text::size inputG) + (Unary (Bytecode Any)) + ($_ _.compose + inputG + ..ensure-string + (_.invokevirtual ..$String "length" (type.method [(list) type.int (list)])) + ..lux-int)) + +(def: no-op (Bytecode Any) (_\wrap [])) + +(template [<name> <pre-subject> <pre-param> <op> <post>] + [(def: (<name> [paramG subjectG]) + (Binary (Bytecode Any)) + ($_ _.compose + subjectG <pre-subject> + paramG <pre-param> + <op> <post>))] + + [text::= ..no-op ..no-op + (_.invokevirtual ..$Object "equals" (type.method [(list ..$Object) type.boolean (list)])) + (///value.wrap type.boolean)] + [text::< ..ensure-string ..ensure-string + (_.invokevirtual ..$String "compareTo" (type.method [(list ..$String) type.int (list)])) + (..predicate _.iflt)] + [text::char ..ensure-string ..jvm-int + (_.invokevirtual ..$String "charAt" (type.method [(list type.int) type.char (list)])) + ..lux-int] + ) + +(def: (text::concat [leftG rightG]) + (Binary (Bytecode Any)) + ($_ _.compose + leftG ..ensure-string + rightG ..ensure-string + (_.invokevirtual ..$String "concat" (type.method [(list ..$String) ..$String (list)])))) + +(def: (text::clip [startG endG subjectG]) + (Trinary (Bytecode Any)) + ($_ _.compose + subjectG ..ensure-string + startG ..jvm-int + endG ..jvm-int + (_.invokevirtual ..$String "substring" (type.method [(list type.int type.int) ..$String (list)])))) + +(def: index-method (type.method [(list ..$String type.int) type.int (list)])) +(def: (text::index [startG partG textG]) + (Trinary (Bytecode Any)) + (do _.monad + [@not-found _.new-label + @end _.new-label] + ($_ _.compose + textG ..ensure-string + partG ..ensure-string + startG ..jvm-int + (_.invokevirtual ..$String "indexOf" index-method) + _.dup + _.iconst-m1 + (_.if-icmpeq @not-found) + ..lux-int + ///runtime.some-injection + (_.goto @end) + (_.set-label @not-found) + _.pop + ///runtime.none-injection + (_.set-label @end)))) + +(def: bundle::text + Bundle + (<| (/////bundle.prefix "text") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "=" (binary ..text::=)) + (/////bundle.install "<" (binary ..text::<)) + (/////bundle.install "concat" (binary ..text::concat)) + (/////bundle.install "index" (trinary ..text::index)) + (/////bundle.install "size" (unary ..text::size)) + (/////bundle.install "char" (binary ..text::char)) + (/////bundle.install "clip" (trinary ..text::clip))))) + +(def: string-method (type.method [(list ..$String) type.void (list)])) +(def: (io::log messageG) + (Unary (Bytecode Any)) + ($_ _.compose + (_.getstatic ..$System "out" ..$PrintStream) + messageG + ..ensure-string + (_.invokevirtual ..$PrintStream "println" ..string-method) + ///runtime.unit)) + +(def: (io::error messageG) + (Unary (Bytecode Any)) + ($_ _.compose + (_.new ..$Error) + _.dup + messageG + ..ensure-string + (_.invokespecial ..$Error "<init>" ..string-method) + _.athrow)) + +(def: bundle::io + Bundle + (<| (/////bundle.prefix "io") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "log" (unary ..io::log)) + (/////bundle.install "error" (unary ..io::error))))) + +(def: #export bundle + Bundle + (<| (/////bundle.prefix "lux") + (|> bundle::lux + (dictionary.merge ..bundle::i64) + (dictionary.merge ..bundle::f64) + (dictionary.merge ..bundle::text) + (dictionary.merge ..bundle::io)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux new file mode 100644 index 000000000..b46934a86 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux @@ -0,0 +1,1106 @@ +(.module: + [library + [lux (#- Type) + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["." exception (#+ exception:)] + ["<>" parser + ["<t>" text] + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [number + ["." i32]] + [collection + ["." list ("#\." monad)] + ["." dictionary (#+ Dictionary)] + ["." set] + ["." row]] + ["." format #_ + ["#" binary]]] + [target + [jvm + ["." version] + ["." modifier ("#\." monoid)] + ["." method (#+ Method)] + ["." class (#+ Class)] + [constant + [pool (#+ Resource)]] + [encoding + ["." name]] + ["_" bytecode (#+ Label Bytecode) ("#\." monad) + ["__" instruction (#+ Primitive-Array-Type)]] + ["." type (#+ Type Typed Argument) + ["." category (#+ Void Value' Value Return' Return Primitive Object Array Var Parameter)] + ["." box] + ["." reflection] + ["." signature] + ["." parser]]]]]] + ["." // #_ + [common (#+ custom)] + ["///#" //// #_ + [generation + [extension (#+ Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)] + ["///" jvm + ["#." runtime (#+ Operation Bundle Phase Handler)] + ["#." reference] + [function + [field + [variable + ["." foreign]]]]]] + [extension + ["#." bundle] + [analysis + ["/" jvm]]] + ["/#" // #_ + [analysis (#+ Environment)] + ["#." synthesis (#+ Synthesis Path %synthesis)] + ["#." generation] + [/// + ["#" phase] + [reference + ["#." variable (#+ Variable)]] + [meta + ["." archive (#+ Archive)]]]]]]) + +(template [<name> <0> <1>] + [(def: <name> + (Bytecode Any) + ($_ _.compose + <0> + <1>))] + + [l2s _.l2i _.i2s] + [l2b _.l2i _.i2b] + [l2c _.l2i _.i2c] + ) + +(template [<conversion> <name>] + [(def: (<name> inputG) + (Unary (Bytecode Any)) + (if (is? _.nop <conversion>) + inputG + ($_ _.compose + inputG + <conversion>)))] + + [_.d2f conversion::double-to-float] + [_.d2i conversion::double-to-int] + [_.d2l conversion::double-to-long] + [_.f2d conversion::float-to-double] + [_.f2i conversion::float-to-int] + [_.f2l conversion::float-to-long] + [_.i2b conversion::int-to-byte] + [_.i2c conversion::int-to-char] + [_.i2d conversion::int-to-double] + [_.i2f conversion::int-to-float] + [_.i2l conversion::int-to-long] + [_.i2s conversion::int-to-short] + [_.l2d conversion::long-to-double] + [_.l2f conversion::long-to-float] + [_.l2i conversion::long-to-int] + [..l2s conversion::long-to-short] + [..l2b conversion::long-to-byte] + [..l2c conversion::long-to-char] + [_.i2b conversion::char-to-byte] + [_.i2s conversion::char-to-short] + [_.nop conversion::char-to-int] + [_.i2l conversion::char-to-long] + [_.i2l conversion::byte-to-long] + [_.i2l conversion::short-to-long] + ) + +(def: bundle::conversion + Bundle + (<| (/////bundle.prefix "conversion") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "double-to-float" (unary conversion::double-to-float)) + (/////bundle.install "double-to-int" (unary conversion::double-to-int)) + (/////bundle.install "double-to-long" (unary conversion::double-to-long)) + (/////bundle.install "float-to-double" (unary conversion::float-to-double)) + (/////bundle.install "float-to-int" (unary conversion::float-to-int)) + (/////bundle.install "float-to-long" (unary conversion::float-to-long)) + (/////bundle.install "int-to-byte" (unary conversion::int-to-byte)) + (/////bundle.install "int-to-char" (unary conversion::int-to-char)) + (/////bundle.install "int-to-double" (unary conversion::int-to-double)) + (/////bundle.install "int-to-float" (unary conversion::int-to-float)) + (/////bundle.install "int-to-long" (unary conversion::int-to-long)) + (/////bundle.install "int-to-short" (unary conversion::int-to-short)) + (/////bundle.install "long-to-double" (unary conversion::long-to-double)) + (/////bundle.install "long-to-float" (unary conversion::long-to-float)) + (/////bundle.install "long-to-int" (unary conversion::long-to-int)) + (/////bundle.install "long-to-short" (unary conversion::long-to-short)) + (/////bundle.install "long-to-byte" (unary conversion::long-to-byte)) + (/////bundle.install "long-to-char" (unary conversion::long-to-char)) + (/////bundle.install "char-to-byte" (unary conversion::char-to-byte)) + (/////bundle.install "char-to-short" (unary conversion::char-to-short)) + (/////bundle.install "char-to-int" (unary conversion::char-to-int)) + (/////bundle.install "char-to-long" (unary conversion::char-to-long)) + (/////bundle.install "byte-to-long" (unary conversion::byte-to-long)) + (/////bundle.install "short-to-long" (unary conversion::short-to-long)) + ))) + +(template [<name> <op>] + [(def: (<name> [xG yG]) + (Binary (Bytecode Any)) + ($_ _.compose + xG + yG + <op>))] + + [int::+ _.iadd] + [int::- _.isub] + [int::* _.imul] + [int::/ _.idiv] + [int::% _.irem] + [int::and _.iand] + [int::or _.ior] + [int::xor _.ixor] + [int::shl _.ishl] + [int::shr _.ishr] + [int::ushr _.iushr] + + [long::+ _.ladd] + [long::- _.lsub] + [long::* _.lmul] + [long::/ _.ldiv] + [long::% _.lrem] + [long::and _.land] + [long::or _.lor] + [long::xor _.lxor] + [long::shl _.lshl] + [long::shr _.lshr] + [long::ushr _.lushr] + + [float::+ _.fadd] + [float::- _.fsub] + [float::* _.fmul] + [float::/ _.fdiv] + [float::% _.frem] + + [double::+ _.dadd] + [double::- _.dsub] + [double::* _.dmul] + [double::/ _.ddiv] + [double::% _.drem] + ) + +(def: $Boolean (type.class box.boolean (list))) +(def: falseG (_.getstatic ..$Boolean "FALSE" ..$Boolean)) +(def: trueG (_.getstatic ..$Boolean "TRUE" ..$Boolean)) + +(template [<name> <op>] + [(def: (<name> [xG yG]) + (Binary (Bytecode Any)) + (do _.monad + [@then _.new-label + @end _.new-label] + ($_ _.compose + xG + yG + (<op> @then) + falseG + (_.goto @end) + (_.set-label @then) + trueG + (_.set-label @end))))] + + [int::= _.if-icmpeq] + [int::< _.if-icmplt] + + [char::= _.if-icmpeq] + [char::< _.if-icmplt] + ) + +(template [<name> <op> <reference>] + [(def: (<name> [xG yG]) + (Binary (Bytecode Any)) + (do _.monad + [@then _.new-label + @end _.new-label] + ($_ _.compose + xG + yG + <op> + (_.int (i32.i32 (.i64 <reference>))) + (_.if-icmpeq @then) + falseG + (_.goto @end) + (_.set-label @then) + trueG + (_.set-label @end))))] + + [long::= _.lcmp +0] + [long::< _.lcmp -1] + + [float::= _.fcmpg +0] + [float::< _.fcmpg -1] + + [double::= _.dcmpg +0] + [double::< _.dcmpg -1] + ) + +(def: bundle::int + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.int)) + (|> (: Bundle /////bundle.empty) + (/////bundle.install "+" (binary int::+)) + (/////bundle.install "-" (binary int::-)) + (/////bundle.install "*" (binary int::*)) + (/////bundle.install "/" (binary int::/)) + (/////bundle.install "%" (binary int::%)) + (/////bundle.install "=" (binary int::=)) + (/////bundle.install "<" (binary int::<)) + (/////bundle.install "and" (binary int::and)) + (/////bundle.install "or" (binary int::or)) + (/////bundle.install "xor" (binary int::xor)) + (/////bundle.install "shl" (binary int::shl)) + (/////bundle.install "shr" (binary int::shr)) + (/////bundle.install "ushr" (binary int::ushr)) + ))) + +(def: bundle::long + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.long)) + (|> (: Bundle /////bundle.empty) + (/////bundle.install "+" (binary long::+)) + (/////bundle.install "-" (binary long::-)) + (/////bundle.install "*" (binary long::*)) + (/////bundle.install "/" (binary long::/)) + (/////bundle.install "%" (binary long::%)) + (/////bundle.install "=" (binary long::=)) + (/////bundle.install "<" (binary long::<)) + (/////bundle.install "and" (binary long::and)) + (/////bundle.install "or" (binary long::or)) + (/////bundle.install "xor" (binary long::xor)) + (/////bundle.install "shl" (binary long::shl)) + (/////bundle.install "shr" (binary long::shr)) + (/////bundle.install "ushr" (binary long::ushr)) + ))) + +(def: bundle::float + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.float)) + (|> (: Bundle /////bundle.empty) + (/////bundle.install "+" (binary float::+)) + (/////bundle.install "-" (binary float::-)) + (/////bundle.install "*" (binary float::*)) + (/////bundle.install "/" (binary float::/)) + (/////bundle.install "%" (binary float::%)) + (/////bundle.install "=" (binary float::=)) + (/////bundle.install "<" (binary float::<)) + ))) + +(def: bundle::double + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.double)) + (|> (: Bundle /////bundle.empty) + (/////bundle.install "+" (binary double::+)) + (/////bundle.install "-" (binary double::-)) + (/////bundle.install "*" (binary double::*)) + (/////bundle.install "/" (binary double::/)) + (/////bundle.install "%" (binary double::%)) + (/////bundle.install "=" (binary double::=)) + (/////bundle.install "<" (binary double::<)) + ))) + +(def: bundle::char + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.char)) + (|> (: Bundle /////bundle.empty) + (/////bundle.install "=" (binary char::=)) + (/////bundle.install "<" (binary char::<)) + ))) + +(template [<name> <category> <parser>] + [(def: #export <name> + (Parser (Type <category>)) + (<t>.embed <parser> <s>.text))] + + [var Var parser.var] + [class category.Class parser.class] + [object Object parser.object] + [value Value parser.value] + [return Return parser.return] + ) + +(exception: #export (not-an-object-array {arrayJT (Type Array)}) + (exception.report + ["JVM Type" (|> arrayJT type.signature signature.signature)])) + +(def: #export object-array + (Parser (Type Object)) + (do <>.monad + [arrayJT (<t>.embed parser.array <s>.text)] + (case (parser.array? arrayJT) + (#.Some elementJT) + (case (parser.object? elementJT) + (#.Some elementJT) + (wrap elementJT) + + #.None + (<>.fail (exception.construct ..not-an-object-array arrayJT))) + + #.None + (undefined)))) + +(def: (primitive-array-length-handler jvm-primitive) + (-> (Type Primitive) Handler) + (..custom + [<s>.any + (function (_ extension-name generate archive arrayS) + (do //////.monad + [arrayG (generate archive arrayS)] + (wrap ($_ _.compose + arrayG + (_.checkcast (type.array jvm-primitive)) + _.arraylength))))])) + +(def: array::length::object + Handler + (..custom + [($_ <>.and ..object-array <s>.any) + (function (_ extension-name generate archive [elementJT arrayS]) + (do //////.monad + [arrayG (generate archive arrayS)] + (wrap ($_ _.compose + arrayG + (_.checkcast (type.array elementJT)) + _.arraylength))))])) + +(def: (new-primitive-array-handler jvm-primitive) + (-> Primitive-Array-Type Handler) + (..custom + [<s>.any + (function (_ extension-name generate archive [lengthS]) + (do //////.monad + [lengthG (generate archive lengthS)] + (wrap ($_ _.compose + lengthG + (_.newarray jvm-primitive)))))])) + +(def: array::new::object + Handler + (..custom + [($_ <>.and ..object <s>.any) + (function (_ extension-name generate archive [objectJT lengthS]) + (do //////.monad + [lengthG (generate archive lengthS)] + (wrap ($_ _.compose + lengthG + (_.anewarray objectJT)))))])) + +(def: (read-primitive-array-handler jvm-primitive loadG) + (-> (Type Primitive) (Bytecode Any) Handler) + (..custom + [($_ <>.and <s>.any <s>.any) + (function (_ extension-name generate archive [idxS arrayS]) + (do //////.monad + [arrayG (generate archive arrayS) + idxG (generate archive idxS)] + (wrap ($_ _.compose + arrayG + (_.checkcast (type.array jvm-primitive)) + idxG + loadG))))])) + +(def: array::read::object + Handler + (..custom + [($_ <>.and ..object-array <s>.any <s>.any) + (function (_ extension-name generate archive [elementJT idxS arrayS]) + (do //////.monad + [arrayG (generate archive arrayS) + idxG (generate archive idxS)] + (wrap ($_ _.compose + arrayG + (_.checkcast (type.array elementJT)) + idxG + _.aaload))))])) + +(def: (write-primitive-array-handler jvm-primitive storeG) + (-> (Type Primitive) (Bytecode Any) Handler) + (..custom + [($_ <>.and <s>.any <s>.any <s>.any) + (function (_ extension-name generate archive [idxS valueS arrayS]) + (do //////.monad + [arrayG (generate archive arrayS) + idxG (generate archive idxS) + valueG (generate archive valueS)] + (wrap ($_ _.compose + arrayG + (_.checkcast (type.array jvm-primitive)) + _.dup + idxG + valueG + storeG))))])) + +(def: array::write::object + Handler + (..custom + [($_ <>.and ..object-array <s>.any <s>.any <s>.any) + (function (_ extension-name generate archive [elementJT idxS valueS arrayS]) + (do //////.monad + [arrayG (generate archive arrayS) + idxG (generate archive idxS) + valueG (generate archive valueS)] + (wrap ($_ _.compose + arrayG + (_.checkcast (type.array elementJT)) + _.dup + idxG + valueG + _.aastore))))])) + +(def: bundle::array + Bundle + (<| (/////bundle.prefix "array") + (|> /////bundle.empty + (dictionary.merge (<| (/////bundle.prefix "length") + (|> /////bundle.empty + (/////bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler type.boolean)) + (/////bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler type.byte)) + (/////bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler type.short)) + (/////bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler type.int)) + (/////bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler type.long)) + (/////bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler type.float)) + (/////bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler type.double)) + (/////bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler type.char)) + (/////bundle.install "object" array::length::object)))) + (dictionary.merge (<| (/////bundle.prefix "new") + (|> /////bundle.empty + (/////bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler __.t-boolean)) + (/////bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler __.t-byte)) + (/////bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler __.t-short)) + (/////bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler __.t-int)) + (/////bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler __.t-long)) + (/////bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler __.t-float)) + (/////bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler __.t-double)) + (/////bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler __.t-char)) + (/////bundle.install "object" array::new::object)))) + (dictionary.merge (<| (/////bundle.prefix "read") + (|> /////bundle.empty + (/////bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler type.boolean _.baload)) + (/////bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler type.byte _.baload)) + (/////bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler type.short _.saload)) + (/////bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler type.int _.iaload)) + (/////bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler type.long _.laload)) + (/////bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler type.float _.faload)) + (/////bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler type.double _.daload)) + (/////bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler type.char _.caload)) + (/////bundle.install "object" array::read::object)))) + (dictionary.merge (<| (/////bundle.prefix "write") + (|> /////bundle.empty + (/////bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler type.boolean _.bastore)) + (/////bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler type.byte _.bastore)) + (/////bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler type.short _.sastore)) + (/////bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler type.int _.iastore)) + (/////bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler type.long _.lastore)) + (/////bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler type.float _.fastore)) + (/////bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler type.double _.dastore)) + (/////bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler type.char _.castore)) + (/////bundle.install "object" array::write::object)))) + ))) + +(def: (object::null _) + (Nullary (Bytecode Any)) + _.aconst-null) + +(def: (object::null? objectG) + (Unary (Bytecode Any)) + (do _.monad + [@then _.new-label + @end _.new-label] + ($_ _.compose + objectG + (_.ifnull @then) + ..falseG + (_.goto @end) + (_.set-label @then) + ..trueG + (_.set-label @end)))) + +(def: (object::synchronized [monitorG exprG]) + (Binary (Bytecode Any)) + ($_ _.compose + monitorG + _.dup + _.monitorenter + exprG + _.swap + _.monitorexit)) + +(def: (object::throw exceptionG) + (Unary (Bytecode Any)) + ($_ _.compose + exceptionG + _.athrow)) + +(def: $Class (type.class "java.lang.Class" (list))) +(def: $String (type.class "java.lang.String" (list))) + +(def: object::class + Handler + (..custom + [<s>.text + (function (_ extension-name generate archive [class]) + (do //////.monad + [] + (wrap ($_ _.compose + (_.string class) + (_.invokestatic ..$Class "forName" (type.method [(list ..$String) ..$Class (list)]))))))])) + +(def: object::instance? + Handler + (..custom + [($_ <>.and <s>.text <s>.any) + (function (_ extension-name generate archive [class objectS]) + (do //////.monad + [objectG (generate archive objectS)] + (wrap ($_ _.compose + objectG + (_.instanceof (type.class class (list))) + (_.invokestatic ..$Boolean "valueOf" (type.method [(list type.boolean) ..$Boolean (list)]))))))])) + +(def: reflection + (All [category] + (-> (Type (<| Return' Value' category)) Text)) + (|>> type.reflection reflection.reflection)) + +(def: object::cast + Handler + (..custom + [($_ <>.and <s>.text <s>.text <s>.any) + (function (_ extension-name generate archive [from to valueS]) + (do //////.monad + [valueG (generate archive valueS)] + (wrap (`` (cond (~~ (template [<object> <type> <unwrap>] + [(and (text\= (..reflection <type>) + from) + (text\= <object> + to)) + (let [$<object> (type.class <object> (list))] + ($_ _.compose + valueG + (_.invokestatic $<object> "valueOf" (type.method [(list <type>) $<object> (list)])))) + + (and (text\= <object> + from) + (text\= (..reflection <type>) + to)) + (let [$<object> (type.class <object> (list))] + ($_ _.compose + valueG + (_.checkcast $<object>) + (_.invokevirtual $<object> <unwrap> (type.method [(list) <type> (list)]))))] + + [box.boolean type.boolean "booleanValue"] + [box.byte type.byte "byteValue"] + [box.short type.short "shortValue"] + [box.int type.int "intValue"] + [box.long type.long "longValue"] + [box.float type.float "floatValue"] + [box.double type.double "doubleValue"] + [box.char type.char "charValue"])) + ## else + valueG)))))])) + +(def: bundle::object + Bundle + (<| (/////bundle.prefix "object") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "null" (nullary object::null)) + (/////bundle.install "null?" (unary object::null?)) + (/////bundle.install "synchronized" (binary object::synchronized)) + (/////bundle.install "throw" (unary object::throw)) + (/////bundle.install "class" object::class) + (/////bundle.install "instance?" object::instance?) + (/////bundle.install "cast" object::cast) + ))) + +(def: primitives + (Dictionary Text (Type Primitive)) + (|> (list [(reflection.reflection reflection.boolean) type.boolean] + [(reflection.reflection reflection.byte) type.byte] + [(reflection.reflection reflection.short) type.short] + [(reflection.reflection reflection.int) type.int] + [(reflection.reflection reflection.long) type.long] + [(reflection.reflection reflection.float) type.float] + [(reflection.reflection reflection.double) type.double] + [(reflection.reflection reflection.char) type.char]) + (dictionary.from-list text.hash))) + +(def: get::static + Handler + (..custom + [($_ <>.and <s>.text <s>.text <s>.text) + (function (_ extension-name generate archive [class field unboxed]) + (do //////.monad + [#let [$class (type.class class (list))]] + (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (wrap (_.getstatic $class field primitive)) + + #.None + (wrap (_.getstatic $class field (type.class unboxed (list)))))))])) + +(def: unitG (_.string //////synthesis.unit)) + +(def: put::static + Handler + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any) + (function (_ extension-name generate archive [class field unboxed valueS]) + (do //////.monad + [valueG (generate archive valueS) + #let [$class (type.class class (list))]] + (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (wrap ($_ _.compose + valueG + (_.putstatic $class field primitive) + ..unitG)) + + #.None + (wrap ($_ _.compose + valueG + (_.checkcast $class) + (_.putstatic $class field $class) + ..unitG)))))])) + +(def: get::virtual + Handler + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any) + (function (_ extension-name generate archive [class field unboxed objectS]) + (do //////.monad + [objectG (generate archive objectS) + #let [$class (type.class class (list)) + getG (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (_.getfield $class field primitive) + + #.None + (_.getfield $class field (type.class unboxed (list))))]] + (wrap ($_ _.compose + objectG + (_.checkcast $class) + getG))))])) + +(def: put::virtual + Handler + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any) + (function (_ extension-name generate archive [class field unboxed valueS objectS]) + (do //////.monad + [valueG (generate archive valueS) + objectG (generate archive objectS) + #let [$class (type.class class (list)) + putG (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (_.putfield $class field primitive) + + #.None + (let [$unboxed (type.class unboxed (list))] + ($_ _.compose + (_.checkcast $unboxed) + (_.putfield $class field $unboxed))))]] + (wrap ($_ _.compose + objectG + (_.checkcast $class) + _.dup + valueG + putG))))])) + +(type: Input (Typed Synthesis)) + +(def: input + (Parser Input) + (<s>.tuple (<>.and ..value <s>.any))) + +(def: (generate-input generate archive [valueT valueS]) + (-> Phase Archive Input (Operation (Typed (Bytecode Any)))) + (do //////.monad + [valueG (generate archive valueS)] + (case (type.primitive? valueT) + (#.Right valueT) + (wrap [valueT valueG]) + + (#.Left valueT) + (wrap [valueT ($_ _.compose + valueG + (_.checkcast valueT))])))) + +(def: (prepare-output outputT) + (-> (Type Return) (Bytecode Any)) + (case (type.void? outputT) + (#.Right outputT) + ..unitG + + (#.Left outputT) + (\ _.monad wrap []))) + +(def: invoke::static + Handler + (..custom + [($_ <>.and ..class <s>.text ..return (<>.some ..input)) + (function (_ extension-name generate archive [class method outputT inputsTS]) + (do {! //////.monad} + [inputsTG (monad.map ! (generate-input generate archive) inputsTS)] + (wrap ($_ _.compose + (monad.map _.monad product.right inputsTG) + (_.invokestatic class method (type.method [(list\map product.left inputsTG) outputT (list)])) + (prepare-output outputT)))))])) + +(template [<name> <invoke>] + [(def: <name> + Handler + (..custom + [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input)) + (function (_ extension-name generate archive [class method outputT objectS inputsTS]) + (do {! //////.monad} + [objectG (generate archive objectS) + inputsTG (monad.map ! (generate-input generate archive) inputsTS)] + (wrap ($_ _.compose + objectG + (_.checkcast class) + (monad.map _.monad product.right inputsTG) + (<invoke> class method (type.method [(list\map product.left inputsTG) outputT (list)])) + (prepare-output outputT)))))]))] + + [invoke::virtual _.invokevirtual] + [invoke::special _.invokespecial] + [invoke::interface _.invokeinterface] + ) + +(def: invoke::constructor + Handler + (..custom + [($_ <>.and ..class (<>.some ..input)) + (function (_ extension-name generate archive [class inputsTS]) + (do {! //////.monad} + [inputsTG (monad.map ! (generate-input generate archive) inputsTS)] + (wrap ($_ _.compose + (_.new class) + _.dup + (monad.map _.monad product.right inputsTG) + (_.invokespecial class "<init>" (type.method [(list\map product.left inputsTG) type.void (list)]))))))])) + +(def: bundle::member + Bundle + (<| (/////bundle.prefix "member") + (|> (: Bundle /////bundle.empty) + (dictionary.merge (<| (/////bundle.prefix "get") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "static" get::static) + (/////bundle.install "virtual" get::virtual)))) + (dictionary.merge (<| (/////bundle.prefix "put") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "static" put::static) + (/////bundle.install "virtual" put::virtual)))) + (dictionary.merge (<| (/////bundle.prefix "invoke") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "static" invoke::static) + (/////bundle.install "virtual" invoke::virtual) + (/////bundle.install "special" invoke::special) + (/////bundle.install "interface" invoke::interface) + (/////bundle.install "constructor" invoke::constructor)))) + ))) + +(def: annotation-parameter + (Parser (/.Annotation-Parameter Synthesis)) + (<s>.tuple (<>.and <s>.text <s>.any))) + +(def: annotation + (Parser (/.Annotation Synthesis)) + (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter)))) + +(def: argument + (Parser Argument) + (<s>.tuple (<>.and <s>.text ..value))) + +(def: overriden-method-definition + (Parser [(Environment Synthesis) (/.Overriden-Method Synthesis)]) + (<s>.tuple (do <>.monad + [_ (<s>.text! /.overriden-tag) + ownerT ..class + name <s>.text + strict-fp? <s>.bit + annotations (<s>.tuple (<>.some ..annotation)) + vars (<s>.tuple (<>.some ..var)) + self-name <s>.text + arguments (<s>.tuple (<>.some ..argument)) + returnT ..return + exceptionsT (<s>.tuple (<>.some ..class)) + [environment body] (<s>.function 1 + (<s>.tuple <s>.any))] + (wrap [environment + [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + body]])))) + +(def: (normalize-path normalize) + (-> (-> Synthesis Synthesis) + (-> Path Path)) + (function (recur path) + (case path + (^ (//////synthesis.path/then bodyS)) + (//////synthesis.path/then (normalize bodyS)) + + (^template [<tag>] + [(^ (<tag> leftP rightP)) + (<tag> (recur leftP) (recur rightP))]) + ([#//////synthesis.Alt] + [#//////synthesis.Seq]) + + (^template [<tag>] + [(^ (<tag> value)) + path]) + ([#//////synthesis.Pop] + [#//////synthesis.Bind] + [#//////synthesis.Access]) + + _ + (undefined)))) + +(def: (normalize-method-body mapping) + (-> (Dictionary Variable Variable) Synthesis Synthesis) + (function (recur body) + (case body + (^template [<tag>] + [(^ (<tag> value)) + body]) + ([#//////synthesis.Primitive] + [//////synthesis.constant]) + + (^ (//////synthesis.variant [lefts right? sub])) + (//////synthesis.variant [lefts right? (recur sub)]) + + (^ (//////synthesis.tuple members)) + (//////synthesis.tuple (list\map recur members)) + + (^ (//////synthesis.variable var)) + (|> mapping + (dictionary.get var) + (maybe.default var) + //////synthesis.variable) + + (^ (//////synthesis.branch/case [inputS pathS])) + (//////synthesis.branch/case [(recur inputS) (normalize-path recur pathS)]) + + (^ (//////synthesis.branch/let [inputS register outputS])) + (//////synthesis.branch/let [(recur inputS) register (recur outputS)]) + + (^ (//////synthesis.branch/if [testS thenS elseS])) + (//////synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)]) + + (^ (//////synthesis.branch/get [path recordS])) + (//////synthesis.branch/get [path (recur recordS)]) + + (^ (//////synthesis.loop/scope [offset initsS+ bodyS])) + (//////synthesis.loop/scope [offset (list\map recur initsS+) (recur bodyS)]) + + (^ (//////synthesis.loop/recur updatesS+)) + (//////synthesis.loop/recur (list\map recur updatesS+)) + + (^ (//////synthesis.function/abstraction [environment arity bodyS])) + (//////synthesis.function/abstraction [(list\map (function (_ local) + (case local + (^ (//////synthesis.variable local)) + (|> mapping + (dictionary.get local) + (maybe.default local) + //////synthesis.variable) + + _ + local)) + environment) + arity + bodyS]) + + (^ (//////synthesis.function/apply [functionS inputsS+])) + (//////synthesis.function/apply [(recur functionS) (list\map recur inputsS+)]) + + (#//////synthesis.Extension [name inputsS+]) + (#//////synthesis.Extension [name (list\map recur inputsS+)])))) + +(def: $Object (type.class "java.lang.Object" (list))) + +(def: (anonymous-init-method env) + (-> (Environment Synthesis) (Type category.Method)) + (type.method [(list.repeat (list.size env) ..$Object) + type.void + (list)])) + +(def: (with-anonymous-init class env super-class inputsTG) + (-> (Type category.Class) (Environment Synthesis) (Type category.Class) (List (Typed (Bytecode Any))) (Resource Method)) + (let [store-capturedG (|> env + list.size + list.indices + (monad.map _.monad (.function (_ register) + ($_ _.compose + (_.aload 0) + (_.aload (inc register)) + (_.putfield class (///reference.foreign-name register) $Object)))))] + (method.method method.public "<init>" (anonymous-init-method env) + (list) + (#.Some ($_ _.compose + (_.aload 0) + (monad.map _.monad product.right inputsTG) + (_.invokespecial super-class "<init>" (type.method [(list\map product.left inputsTG) type.void (list)])) + store-capturedG + _.return))))) + +(def: (anonymous-instance generate archive class env) + (-> Phase Archive (Type category.Class) (Environment Synthesis) (Operation (Bytecode Any))) + (do {! //////.monad} + [captureG+ (monad.map ! (generate archive) env)] + (wrap ($_ _.compose + (_.new class) + _.dup + (monad.seq _.monad captureG+) + (_.invokespecial class "<init>" (anonymous-init-method env)))))) + +(def: (returnG returnT) + (-> (Type Return) (Bytecode Any)) + (case (type.void? returnT) + (#.Right returnT) + _.return + + (#.Left returnT) + (case (type.primitive? returnT) + (#.Left returnT) + ($_ _.compose + (_.checkcast returnT) + _.areturn) + + (#.Right returnT) + (cond (or (\ type.equivalence = type.boolean returnT) + (\ type.equivalence = type.byte returnT) + (\ type.equivalence = type.short returnT) + (\ type.equivalence = type.int returnT) + (\ type.equivalence = type.char returnT)) + _.ireturn + + (\ type.equivalence = type.long returnT) + _.lreturn + + (\ type.equivalence = type.float returnT) + _.freturn + + ## (\ type.equivalence = type.double returnT) + _.dreturn)))) + +(def: class::anonymous + Handler + (..custom + [($_ <>.and + ..class + (<s>.tuple (<>.some ..class)) + (<s>.tuple (<>.some ..input)) + (<s>.tuple (<>.some ..overriden-method-definition))) + (function (_ extension-name generate archive [super-class super-interfaces + inputsTS + overriden-methods]) + (do {! //////.monad} + [[context _] (//////generation.with-new-context archive (wrap [])) + #let [[module-id artifact-id] context + anonymous-class-name (///runtime.class-name context) + class (type.class anonymous-class-name (list)) + total-environment (|> overriden-methods + ## Get all the environments. + (list\map product.left) + ## Combine them. + list\join + ## Remove duplicates. + (set.from-list //////synthesis.hash) + set.to-list) + global-mapping (|> total-environment + ## Give them names as "foreign" variables. + list.enumeration + (list\map (function (_ [id capture]) + [capture (#//////variable.Foreign id)])) + (dictionary.from-list //////variable.hash)) + normalized-methods (list\map (function (_ [environment + [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + body]]) + (let [local-mapping (|> environment + list.enumeration + (list\map (function (_ [foreign-id capture]) + [(#//////variable.Foreign foreign-id) + (|> global-mapping + (dictionary.get capture) + maybe.assume)])) + (dictionary.from-list //////variable.hash))] + [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + (normalize-method-body local-mapping body)])) + overriden-methods)] + inputsTI (monad.map ! (generate-input generate archive) inputsTS) + method-definitions (monad.map ! (function (_ [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + bodyS]) + (do ! + [bodyG (//////generation.with-context artifact-id + (generate archive bodyS))] + (wrap (method.method ($_ modifier\compose + method.public + method.final + (if strict-fp? + method.strict + modifier\identity)) + name + (type.method [(list\map product.right arguments) + returnT + exceptionsT]) + (list) + (#.Some ($_ _.compose + bodyG + (returnG returnT))))))) + normalized-methods) + bytecode (<| (\ ! map (format.run class.writer)) + //////.lift + (class.class version.v6_0 ($_ modifier\compose class.public class.final) + (name.internal anonymous-class-name) + (name.internal (..reflection super-class)) + (list\map (|>> ..reflection name.internal) super-interfaces) + (foreign.variables total-environment) + (list& (..with-anonymous-init class total-environment super-class inputsTI) + method-definitions) + (row.row))) + _ (//////generation.execute! [anonymous-class-name bytecode]) + _ (//////generation.save! (%.nat artifact-id) [anonymous-class-name bytecode])] + (anonymous-instance generate archive class total-environment)))])) + +(def: bundle::class + Bundle + (<| (/////bundle.prefix "class") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "anonymous" class::anonymous) + ))) + +(def: #export bundle + Bundle + (<| (/////bundle.prefix "jvm") + (|> ..bundle::conversion + (dictionary.merge ..bundle::int) + (dictionary.merge ..bundle::long) + (dictionary.merge ..bundle::float) + (dictionary.merge ..bundle::double) + (dictionary.merge ..bundle::char) + (dictionary.merge ..bundle::array) + (dictionary.merge ..bundle::object) + (dictionary.merge ..bundle::member) + (dictionary.merge ..bundle::class) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux new file mode 100644 index 000000000..1f1bd7f91 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux @@ -0,0 +1,18 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [lua + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux new file mode 100644 index 000000000..b31bf5610 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux @@ -0,0 +1,181 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary] + ["." list ("#\." functor fold)]]] + [math + [number + ["f" frac]]] + ["@" target + ["_" lua (#+ Expression)]]]] + ["." //// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" lua #_ + ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]] + [// + [synthesis (#+ %synthesis)] + ["." generation] + [/// + ["#" phase]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension_name phase archive input') + + (#try.Failure error) + (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) + +(template: (!unary function) + (|>> list _.apply/* (|> (_.var function)))) + +## TODO: Get rid of this ASAP +(def: lux::syntax_char_case! + (..custom [($_ <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple ($_ <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension_name phase archive [input else conditionals]) + (do {! /////.monad} + [inputG (phase archive input) + elseG (phase archive else) + @input (\ ! map _.var (generation.gensym "input")) + conditionalsG (: (Operation (List [Expression Expression])) + (monad.map ! (function (_ [chars branch]) + (do ! + [branchG (phase archive branch)] + (wrap [(|> chars + (list\map (|>> .int _.int (_.= @input))) + (list\fold (function (_ clause total) + (if (is? _.nil total) + clause + (_.or clause total))) + _.nil)) + branchG]))) + conditionals)) + #let [closure (_.closure (list @input) + (list\fold (function (_ [test then] else) + (_.if test (_.return then) else)) + (_.return elseG) + conditionalsG))]] + (wrap (_.apply/1 closure inputG))))])) + +(def: lux_procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (product.uncurry _.=))) + (/.install "try" (unary //runtime.lux//try)))) + +(def: i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurry _.bit_and))) + (/.install "or" (binary (product.uncurry _.bit_or))) + (/.install "xor" (binary (product.uncurry _.bit_xor))) + (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift))) + (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) + (/.install "=" (binary (product.uncurry _.=))) + (/.install "+" (binary (product.uncurry _.+))) + (/.install "-" (binary (product.uncurry _.-))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "*" (binary (product.uncurry _.*))) + (/.install "/" (binary (product.uncurry //runtime.i64//division))) + (/.install "%" (binary (product.uncurry //runtime.i64//remainder))) + (/.install "f64" (unary (_./ (_.float +1.0)))) + (/.install "char" (unary (_.apply/1 (_.var "utf8.char")))) + ))) + +(def: f64//decode + (Unary Expression) + (|>> list _.apply/* (|> (_.var "tonumber")) _.return (_.closure (list)) //runtime.lux//try)) + +(def: f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "+" (binary (product.uncurry _.+))) + (/.install "-" (binary (product.uncurry _.-))) + (/.install "*" (binary (product.uncurry _.*))) + (/.install "/" (binary (product.uncurry _./))) + (/.install "%" (binary (product.uncurry (function.flip (_.apply/2 (_.var "math.fmod")))))) + (/.install "=" (binary (product.uncurry _.=))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "i64" (unary (!unary "math.floor"))) + (/.install "encode" (unary (_.apply/2 (_.var "string.format") (_.string "%.17g")))) + (/.install "decode" (unary ..f64//decode))))) + +(def: (text//char [paramO subjectO]) + (Binary Expression) + (//runtime.text//char (_.+ (_.int +1) paramO) subjectO)) + +(def: (text//clip [paramO extraO subjectO]) + (Trinary Expression) + (//runtime.text//clip subjectO paramO extraO)) + +(def: (text//index [startO partO textO]) + (Trinary Expression) + (//runtime.text//index textO partO startO)) + +(def: text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurry _.=))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "concat" (binary (product.uncurry (function.flip _.concat)))) + (/.install "index" (trinary ..text//index)) + (/.install "size" (unary //runtime.text//size)) + ## TODO: Use version below once the Lua compiler becomes self-hosted. + ## (/.install "size" (unary (for {@.lua (!unary "utf8.len")} + ## (!unary "string.len")))) + (/.install "char" (binary ..text//char)) + (/.install "clip" (trinary ..text//clip)) + ))) + +(def: (io//log! messageO) + (Unary Expression) + (|> (_.apply/* (list messageO) (_.var "print")) + (_.or //runtime.unit))) + +(def: io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary ..io//log!)) + (/.install "error" (unary (!unary "error")))))) + +(def: #export bundle + Bundle + (<| (/.prefix "lux") + (|> lux_procs + (dictionary.merge i64_procs) + (dictionary.merge f64_procs) + (dictionary.merge text_procs) + (dictionary.merge io_procs) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux new file mode 100644 index 000000000..1bb7d771c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux @@ -0,0 +1,200 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + [collection + ["." dictionary] + ["." list]] + [text + ["%" format (#+ format)]]] + [target + ["_" lua (#+ Var Expression)]]]] + ["." // #_ + ["#." common (#+ custom)] + ["//#" /// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" lua #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with_vars)]]] + ["/#" // #_ + ["." generation] + ["//#" /// #_ + ["#." phase]]]]]]) + +(def: array::new + (Unary Expression) + (|>> ["n"] list _.table)) + +(def: array::length + (Unary Expression) + (_.the "n")) + +(def: (array::read [indexG arrayG]) + (Binary Expression) + (_.nth (_.+ (_.int +1) indexG) arrayG)) + +(def: (array::write [indexG valueG arrayG]) + (Trinary Expression) + (//runtime.array//write indexG valueG arrayG)) + +(def: (array::delete [indexG arrayG]) + (Binary Expression) + (//runtime.array//write indexG _.nil arrayG)) + +(def: array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary array::length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(def: object::get + Handler + (custom + [($_ <>.and <s>.text <s>.any) + (function (_ extension phase archive [fieldS objectS]) + (do ////////phase.monad + [objectG (phase archive objectS)] + (wrap (_.the fieldS objectG))))])) + +(def: object::do + Handler + (custom + [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [methodS objectS inputsS]) + (do {! ////////phase.monad} + [objectG (phase archive objectS) + inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.do methodS inputsG objectG))))])) + +(template [<!> <?> <unit>] + [(def: <!> (Nullary Expression) (function.constant <unit>)) + (def: <?> (Unary Expression) (_.= <unit>))] + + [object::nil object::nil? _.nil] + ) + +(def: object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "get" object::get) + (/.install "do" object::do) + (/.install "nil" (nullary object::nil)) + (/.install "nil?" (unary object::nil?)) + ))) + +(def: $input + (_.var "input")) + +(def: utf8::encode + (custom + [<s>.any + (function (_ extension phase archive inputS) + (do {! ////////phase.monad} + [inputG (phase archive inputS)] + (wrap (_.apply/1 (<| (_.closure (list $input)) + (_.return (|> (_.var "string.byte") + (_.apply/* (list $input (_.int +1) (_.length $input))) + (_.apply/1 (_.var "table.pack"))))) + inputG))))])) + +(def: utf8::decode + (custom + [<s>.any + (function (_ extension phase archive inputS) + (do {! ////////phase.monad} + [inputG (phase archive inputS)] + (wrap (|> inputG + (_.apply/1 (_.var "table.unpack")) + (_.apply/1 (_.var "string.char"))))))])) + +(def: utf8 + Bundle + (<| (/.prefix "utf8") + (|> /.empty + (/.install "encode" utf8::encode) + (/.install "decode" utf8::decode) + ))) + +(def: lua::constant + (custom + [<s>.text + (function (_ extension phase archive name) + (\ ////////phase.monad wrap (_.var name)))])) + +(def: lua::apply + (custom + [($_ <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [abstractionS inputsS]) + (do {! ////////phase.monad} + [abstractionG (phase archive abstractionS) + inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.apply/* inputsG abstractionG))))])) + +(def: lua::power + (custom + [($_ <>.and <s>.any <s>.any) + (function (_ extension phase archive [powerS baseS]) + (do {! ////////phase.monad} + [powerG (phase archive powerS) + baseG (phase archive baseS)] + (wrap (_.^ powerG baseG))))])) + +(def: lua::import + (custom + [<s>.text + (function (_ extension phase archive module) + (\ ////////phase.monad wrap + (_.require/1 (_.string module))))])) + +(def: lua::function + (custom + [($_ <>.and <s>.i64 <s>.any) + (function (_ extension phase archive [arity abstractionS]) + (do {! ////////phase.monad} + [abstractionG (phase archive abstractionS) + #let [variable (: (-> Text (Operation Var)) + (|>> generation.gensym + (\ ! map _.var)))] + g!inputs (monad.map ! (function (_ _) + (variable "input")) + (list.repeat (.nat arity) []))] + (wrap (<| (_.closure g!inputs) + _.statement + (case (.nat arity) + 0 (_.apply/1 abstractionG //runtime.unit) + 1 (_.apply/* g!inputs abstractionG) + _ (_.apply/1 abstractionG (_.array g!inputs)))))))])) + +(def: #export bundle + Bundle + (<| (/.prefix "lua") + (|> /.empty + (dictionary.merge ..array) + (dictionary.merge ..object) + (dictionary.merge ..utf8) + + (/.install "constant" lua::constant) + (/.install "apply" lua::apply) + (/.install "power" lua::power) + (/.install "import" lua::import) + (/.install "function" lua::function) + (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php.lux new file mode 100644 index 000000000..751e67a85 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php.lux @@ -0,0 +1,18 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [php + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux new file mode 100644 index 000000000..2d31a6b71 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux @@ -0,0 +1,192 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary] + ["." set] + ["." list ("#\." functor fold)]]] + [math + [number + ["f" frac]]] + ["@" target + ["_" php (#+ Expression)]]]] + ["." //// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" php #_ + ["#." runtime (#+ Operation Phase Handler Bundle Generator)] + ["#." case]]] + [// + ["." synthesis (#+ %synthesis)] + ["." generation] + [/// + ["#" phase]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension_name phase archive input') + + (#try.Failure error) + (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) + +(template: (!unary function) + (|>> list _.apply/* (|> (_.constant function)))) + +## TODO: Get rid of this ASAP +(def: lux::syntax_char_case! + (..custom [($_ <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple ($_ <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension_name phase archive [input else conditionals]) + (do {! /////.monad} + [inputG (phase archive input) + [[context_module context_artifact] elseG] (generation.with_new_context archive + (phase archive else)) + @input (\ ! map _.var (generation.gensym "input")) + conditionalsG (: (Operation (List [Expression Expression])) + (monad.map ! (function (_ [chars branch]) + (do ! + [branchG (phase archive branch)] + (wrap [(|> chars + (list\map (|>> .int _.int (_.=== @input))) + (list\fold (function (_ clause total) + (if (is? _.null total) + clause + (_.or clause total))) + _.null)) + branchG]))) + conditionals)) + #let [foreigns (|> conditionals + (list\map (|>> product.right synthesis.path/then //case.dependencies)) + (list& (//case.dependencies (synthesis.path/then else))) + list.concat + (set.from_list _.hash) + set.to_list) + @expression (_.constant (reference.artifact [context_module context_artifact])) + directive (_.define_function @expression (list& (_.parameter @input) (list\map _.reference foreigns)) + (list\fold (function (_ [test then] else) + (_.if test (_.return then) else)) + (_.return elseG) + conditionalsG))] + _ (generation.execute! directive) + _ (generation.save! context_artifact directive)] + (wrap (_.apply/* (list& inputG foreigns) @expression))))])) + +(def: lux_procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (product.uncurry _.===))) + (/.install "try" (unary //runtime.lux//try)) + )) + +(def: (left_shift [parameter subject]) + (Binary Expression) + (_.bit_shl (_.% (_.int +64) parameter) subject)) + +(def: i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurry _.bit_and))) + (/.install "or" (binary (product.uncurry _.bit_or))) + (/.install "xor" (binary (product.uncurry _.bit_xor))) + (/.install "left-shift" (binary ..left_shift)) + (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) + (/.install "=" (binary (product.uncurry _.==))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "+" (binary (product.uncurry //runtime.i64//+))) + (/.install "-" (binary (product.uncurry //runtime.i64//-))) + (/.install "*" (binary (product.uncurry //runtime.i64//*))) + (/.install "/" (binary (function (_ [parameter subject]) + (_.intdiv/2 [subject parameter])))) + (/.install "%" (binary (product.uncurry _.%))) + (/.install "f64" (unary (_./ (_.float +1.0)))) + (/.install "char" (unary //runtime.i64//char)) + ))) + +(def: (f64//% [parameter subject]) + (Binary Expression) + (_.fmod/2 [subject parameter])) + +(def: (f64//encode subject) + (Unary Expression) + (_.number_format/2 [subject (_.int +17)])) + +(def: f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "=" (binary (product.uncurry _.==))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "+" (binary (product.uncurry _.+))) + (/.install "-" (binary (product.uncurry _.-))) + (/.install "*" (binary (product.uncurry _.*))) + (/.install "/" (binary (product.uncurry _./))) + (/.install "%" (binary ..f64//%)) + (/.install "i64" (unary _.intval/1)) + (/.install "encode" (unary ..f64//encode)) + (/.install "decode" (unary //runtime.f64//decode))))) + +(def: (text//clip [paramO extraO subjectO]) + (Trinary Expression) + (//runtime.text//clip paramO extraO subjectO)) + +(def: (text//index [startO partO textO]) + (Trinary Expression) + (//runtime.text//index textO partO startO)) + +(def: text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurry _.==))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "concat" (binary (product.uncurry (function.flip _.concat)))) + (/.install "index" (trinary ..text//index)) + (/.install "size" (unary //runtime.text//size)) + (/.install "char" (binary (product.uncurry //runtime.text//char))) + (/.install "clip" (trinary ..text//clip)) + ))) + +(def: io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary //runtime.io//log!)) + (/.install "error" (unary //runtime.io//throw!))))) + +(def: #export bundle + Bundle + (<| (/.prefix "lux") + (|> /.empty + (dictionary.merge lux_procs) + (dictionary.merge i64_procs) + (dictionary.merge f64_procs) + (dictionary.merge text_procs) + (dictionary.merge io_procs)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux new file mode 100644 index 000000000..ab01b5938 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux @@ -0,0 +1,143 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + [collection + ["." dictionary] + ["." list]] + [text + ["%" format (#+ format)]]] + [target + ["_" php (#+ Var Expression)]]]] + ["." // #_ + ["#." common (#+ custom)] + ["//#" /// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" php #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with_vars)]]] + ["/#" // #_ + ["." generation] + ["//#" /// #_ + ["#." phase]]]]]]) + +(def: (array::new size) + (Unary Expression) + (//runtime.tuple//make size (_.array_fill/3 [(_.int +0) size _.null]))) + +(def: (array::read [indexG arrayG]) + (Binary Expression) + (_.nth indexG arrayG)) + +(def: (array::write [indexG valueG arrayG]) + (Trinary Expression) + (//runtime.array//write indexG valueG arrayG)) + +(def: (array::delete [indexG arrayG]) + (Binary Expression) + (//runtime.array//write indexG _.null arrayG)) + +(def: array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary //runtime.array//length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(def: object::new + (custom + [($_ <>.and <s>.text (<>.some <s>.any)) + (function (_ extension phase archive [constructor inputsS]) + (do {! ////////phase.monad} + [inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.new (_.constant constructor) inputsG))))])) + +(def: object::get + Handler + (custom + [($_ <>.and <s>.text <s>.any) + (function (_ extension phase archive [fieldS objectS]) + (do ////////phase.monad + [objectG (phase archive objectS)] + (wrap (_.the fieldS objectG))))])) + +(def: object::do + Handler + (custom + [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [methodS objectS inputsS]) + (do {! ////////phase.monad} + [objectG (phase archive objectS) + inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.do methodS inputsG objectG))))])) + +(template [<!> <?> <unit>] + [(def: <!> (Nullary Expression) (function.constant <unit>)) + (def: <?> (Unary Expression) (_.=== <unit>))] + + [object::null object::null? _.null] + ) + +(def: object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "new" object::new) + (/.install "get" object::get) + (/.install "do" object::do) + (/.install "null" (nullary object::null)) + (/.install "null?" (unary object::null?)) + ))) + +(def: php::constant + (custom + [<s>.text + (function (_ extension phase archive name) + (\ ////////phase.monad wrap (_.constant name)))])) + +(def: php::apply + (custom + [($_ <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [abstractionS inputsS]) + (do {! ////////phase.monad} + [abstractionG (phase archive abstractionS) + inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.apply/* inputsG abstractionG))))])) + +(def: php::pack + (custom + [($_ <>.and <s>.any <s>.any) + (function (_ extension phase archive [formatS dataS]) + (do {! ////////phase.monad} + [formatG (phase archive formatS) + dataG (phase archive dataS)] + (wrap (_.pack/2 [formatG (_.splat dataG)]))))])) + +(def: #export bundle + Bundle + (<| (/.prefix "php") + (|> /.empty + (dictionary.merge ..array) + (dictionary.merge ..object) + + (/.install "constant" php::constant) + (/.install "apply" php::apply) + (/.install "pack" php::pack) + (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python.lux new file mode 100644 index 000000000..2309732f3 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python.lux @@ -0,0 +1,18 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [python + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux new file mode 100644 index 000000000..da9ab4a4b --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux @@ -0,0 +1,171 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary] + ["." list ("#\." functor fold)]]] + [math + [number + ["f" frac]]] + [target + ["_" python (#+ Expression)]]]] + ["." //// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" python #_ + ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]] + [// + [synthesis (#+ %synthesis)] + ["." generation] + [/// + ["#" phase]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension_name phase archive input') + + (#try.Failure error) + (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) + +## TODO: Get rid of this ASAP +(def: lux::syntax_char_case! + (..custom [($_ <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple ($_ <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension_name phase archive [input else conditionals]) + (do {! /////.monad} + [inputG (phase archive input) + elseG (phase archive else) + @input (\ ! map _.var (generation.gensym "input")) + conditionalsG (: (Operation (List [(Expression Any) + (Expression Any)])) + (monad.map ! (function (_ [chars branch]) + (do ! + [branchG (phase archive branch)] + (wrap [(|> chars + (list\map (|>> .int _.int (_.= @input))) + (list\fold (function (_ clause total) + (if (is? _.none total) + clause + (_.or clause total))) + _.none)) + branchG]))) + conditionals)) + #let [closure (_.lambda (list @input) + (list\fold (function (_ [test then] else) + (_.? test then else)) + elseG + conditionalsG))]] + (wrap (_.apply/* closure (list inputG)))))])) + +(def: lux_procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (product.uncurry _.is))) + (/.install "try" (unary //runtime.lux::try)))) + +(def: (capped operation parameter subject) + (-> (-> (Expression Any) (Expression Any) (Expression Any)) + (-> (Expression Any) (Expression Any) (Expression Any))) + (//runtime.i64::64 (operation parameter subject))) + +(def: i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurry //runtime.i64::and))) + (/.install "or" (binary (product.uncurry //runtime.i64::or))) + (/.install "xor" (binary (product.uncurry //runtime.i64::xor))) + (/.install "left-shift" (binary (product.uncurry //runtime.i64::left_shift))) + (/.install "right-shift" (binary (product.uncurry //runtime.i64::right_shift))) + + (/.install "<" (binary (product.uncurry _.<))) + (/.install "=" (binary (product.uncurry _.=))) + (/.install "+" (binary (product.uncurry (..capped _.+)))) + (/.install "-" (binary (product.uncurry (..capped _.-)))) + (/.install "*" (binary (product.uncurry (..capped _.*)))) + (/.install "/" (binary (product.uncurry //runtime.i64::division))) + (/.install "%" (binary (product.uncurry //runtime.i64::remainder))) + (/.install "f64" (unary _.float/1)) + (/.install "char" (unary //runtime.i64::char)) + ))) + +(def: f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "+" (binary (product.uncurry _.+))) + (/.install "-" (binary (product.uncurry _.-))) + (/.install "*" (binary (product.uncurry _.*))) + (/.install "/" (binary (product.uncurry //runtime.f64::/))) + (/.install "%" (binary (function (_ [parameter subject]) + (|> (_.__import__/1 (_.unicode "math")) + (_.do "fmod" (list subject parameter)))))) + (/.install "=" (binary (product.uncurry _.=))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "i64" (unary _.int/1)) + (/.install "encode" (unary _.repr/1)) + (/.install "decode" (unary //runtime.f64::decode))))) + +(def: (text::clip [paramO extraO subjectO]) + (Trinary (Expression Any)) + (//runtime.text::clip paramO extraO subjectO)) + +(def: (text::index [startO partO textO]) + (Trinary (Expression Any)) + (//runtime.text::index startO partO textO)) + +(def: text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurry _.=))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "concat" (binary (product.uncurry (function.flip _.+)))) + (/.install "index" (trinary ..text::index)) + (/.install "size" (unary _.len/1)) + (/.install "char" (binary (product.uncurry //runtime.text::char))) + (/.install "clip" (trinary ..text::clip)) + ))) + +(def: io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary //runtime.io::log!)) + (/.install "error" (unary //runtime.io::throw!))))) + +(def: #export bundle + Bundle + (<| (/.prefix "lux") + (|> lux_procs + (dictionary.merge i64_procs) + (dictionary.merge f64_procs) + (dictionary.merge text_procs) + (dictionary.merge io_procs) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux new file mode 100644 index 000000000..6612cda07 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux @@ -0,0 +1,165 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + [collection + ["." dictionary] + ["." list]]] + [target + ["_" python (#+ Expression SVar)]]]] + ["." // #_ + ["#." common (#+ custom)] + ["//#" /// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" python #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with_vars)]]] + ["/#" // #_ + ["." generation] + ["//#" /// #_ + ["#." phase]]]]]]) + +(def: (array::new size) + (Unary (Expression Any)) + (|> (list _.none) + _.list + (_.* size))) + +(def: array::length + (Unary (Expression Any)) + (|>> _.len/1 //runtime.i64::64)) + +(def: (array::read [indexG arrayG]) + (Binary (Expression Any)) + (_.nth indexG arrayG)) + +(def: (array::write [indexG valueG arrayG]) + (Trinary (Expression Any)) + (//runtime.array::write indexG valueG arrayG)) + +(def: (array::delete [indexG arrayG]) + (Binary (Expression Any)) + (//runtime.array::write indexG _.none arrayG)) + +(def: array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary array::length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(def: object::get + Handler + (custom + [($_ <>.and <s>.text <s>.any) + (function (_ extension phase archive [fieldS objectS]) + (do ////////phase.monad + [objectG (phase archive objectS)] + (wrap (_.the fieldS objectG))))])) + +(def: object::do + Handler + (custom + [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [methodS objectS inputsS]) + (do {! ////////phase.monad} + [objectG (phase archive objectS) + inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.do methodS inputsG objectG))))])) + +(template [<!> <?> <unit>] + [(def: <!> (Nullary (Expression Any)) (function.constant <unit>)) + (def: <?> (Unary (Expression Any)) (_.= <unit>))] + + [object::none object::none? _.none] + ) + +(def: object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "get" object::get) + (/.install "do" object::do) + (/.install "none" (nullary object::none)) + (/.install "none?" (unary object::none?)) + ))) + +(def: python::constant + (custom + [<s>.text + (function (_ extension phase archive name) + (do ////////phase.monad + [] + (wrap (_.var name))))])) + +(def: python::import + (custom + [<s>.text + (function (_ extension phase archive module) + (do ////////phase.monad + [] + (wrap (_.apply/* (_.var "__import__") (list (_.string module))))))])) + +(def: python::apply + (custom + [($_ <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [abstractionS inputsS]) + (do {! ////////phase.monad} + [abstractionG (phase archive abstractionS) + inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.apply/* abstractionG inputsG))))])) + +(def: python::function + (custom + [($_ <>.and <s>.i64 <s>.any) + (function (_ extension phase archive [arity abstractionS]) + (do {! ////////phase.monad} + [abstractionG (phase archive abstractionS) + #let [variable (: (-> Text (Operation SVar)) + (|>> generation.gensym + (\ ! map _.var)))] + g!inputs (monad.map ! (function (_ _) (variable "input")) + (list.repeat (.nat arity) []))] + (wrap (_.lambda g!inputs + (case (.nat arity) + 0 (_.apply/1 abstractionG //runtime.unit) + 1 (_.apply/* abstractionG g!inputs) + _ (_.apply/1 abstractionG (_.list g!inputs)))))))])) + +(def: python::exec + (custom + [($_ <>.and <s>.any <s>.any) + (function (_ extension phase archive [codeS globalsS]) + (do {! ////////phase.monad} + [codeG (phase archive codeS) + globalsG (phase archive globalsS)] + (wrap (//runtime.lux::exec codeG globalsG))))])) + +(def: #export bundle + Bundle + (<| (/.prefix "python") + (|> /.empty + (dictionary.merge ..array) + (dictionary.merge ..object) + + (/.install "constant" python::constant) + (/.install "import" python::import) + (/.install "apply" python::apply) + (/.install "function" python::function) + (/.install "exec" python::exec) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r.lux new file mode 100644 index 000000000..7ca8195f7 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r.lux @@ -0,0 +1,18 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [r + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux new file mode 100644 index 000000000..36238f9e3 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux @@ -0,0 +1,179 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary] + ["." set] + ["." list ("#\." functor fold)]]] + [math + [number + ["f" frac]]] + ["@" target + ["_" r (#+ Expression)]]]] + ["." //// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" r #_ + ["#." runtime (#+ Operation Phase Handler Bundle Generator)] + ["#." case]]] + [// + ["." synthesis (#+ %synthesis)] + ["." generation] + [/// + ["#" phase]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension_name phase archive input') + + (#try.Failure error) + (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) + +## (template: (!unary function) +## (|>> list _.apply/* (|> (_.constant function)))) + +## ## ## TODO: Get rid of this ASAP +## ## (def: lux::syntax_char_case! +## ## (..custom [($_ <>.and +## ## <s>.any +## ## <s>.any +## ## (<>.some (<s>.tuple ($_ <>.and +## ## (<s>.tuple (<>.many <s>.i64)) +## ## <s>.any)))) +## ## (function (_ extension_name phase archive [input else conditionals]) +## ## (do {! /////.monad} +## ## [@input (\ ! map _.var (generation.gensym "input")) +## ## inputG (phase archive input) +## ## elseG (phase archive else) +## ## conditionalsG (: (Operation (List [Expression Expression])) +## ## (monad.map ! (function (_ [chars branch]) +## ## (do ! +## ## [branchG (phase archive branch)] +## ## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or) +## ## branchG]))) +## ## conditionals))] +## ## (wrap (_.let (list [@input inputG]) +## ## (list (list\fold (function (_ [test then] else) +## ## (_.if test then else)) +## ## elseG +## ## conditionalsG))))))])) + +## (def: lux_procs +## Bundle +## (|> /.empty +## ## (/.install "syntax char case!" lux::syntax_char_case!) +## (/.install "is" (binary _.eq/2)) +## ## (/.install "try" (unary //runtime.lux//try)) +## )) + +## ## (def: (capped operation parameter subject) +## ## (-> (-> Expression Expression Expression) +## ## (-> Expression Expression Expression)) +## ## (//runtime.i64//64 (operation parameter subject))) + +(def: i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + ## (/.install "and" (binary _.logand/2)) + ## (/.install "or" (binary _.logior/2)) + ## (/.install "xor" (binary _.logxor/2)) + ## (/.install "left-shift" (binary _.ash/2)) + ## (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) + ## (/.install "=" (binary _.=/2)) + ## (/.install "<" (binary _.</2)) + ## (/.install "+" (binary _.+/2)) + ## (/.install "-" (binary _.-/2)) + ## (/.install "*" (binary _.*/2)) + ## (/.install "/" (binary _.floor/2)) + ## (/.install "%" (binary _.rem/2)) + ## (/.install "f64" (unary (_.//2 (_.float +1.0)))) + (/.install "char" (unary (|>> //runtime.i64_low _.intToUtf8/1))) + ))) + +## (def: f64_procs +## Bundle +## (<| (/.prefix "f64") +## (|> /.empty +## ## (/.install "=" (binary (product.uncurry _.=/2))) +## ## (/.install "<" (binary (product.uncurry _.</2))) +## ## (/.install "+" (binary (product.uncurry _.+/2))) +## ## (/.install "-" (binary (product.uncurry _.-/2))) +## ## (/.install "*" (binary (product.uncurry _.*/2))) +## ## (/.install "/" (binary (product.uncurry _.//2))) +## ## (/.install "%" (binary (product.uncurry _.rem/2))) +## ## (/.install "i64" (unary _.truncate/1)) +## (/.install "encode" (unary _.write-to-string/1)) +## ## (/.install "decode" (unary //runtime.f64//decode)) +## ))) + +## (def: (text//index [offset sub text]) +## (Trinary (Expression Any)) +## (//runtime.text//index offset sub text)) + +## (def: (text//clip [offset length text]) +## (Trinary (Expression Any)) +## (//runtime.text//clip offset length text)) + +## (def: (text//char [index text]) +## (Binary (Expression Any)) +## (_.char-code/1 (_.char/2 [text index]))) + +(def: text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + ## (/.install "=" (binary _.string=/2)) + ## (/.install "<" (binary (product.uncurry _.string<?/2))) + (/.install "concat" (binary _.paste/2)) + ## (/.install "index" (trinary ..text//index)) + ## (/.install "size" (unary _.length/1)) + ## (/.install "char" (binary ..text//char)) + ## (/.install "clip" (trinary ..text//clip)) + ))) + +## (def: (io//log! message) +## (Unary (Expression Any)) +## (_.progn (list (_.write-line/1 message) +## //runtime.unit))) + +## (def: io_procs +## Bundle +## (<| (/.prefix "io") +## (|> /.empty +## (/.install "log" (unary ..io//log!)) +## (/.install "error" (unary _.error/1)) +## ))) + +(def: #export bundle + Bundle + (<| (/.prefix "lux") + (|> /.empty + ## (dictionary.merge lux_procs) + (dictionary.merge i64_procs) + ## (dictionary.merge f64_procs) + (dictionary.merge text_procs) + ## (dictionary.merge io_procs) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux new file mode 100644 index 000000000..37390f799 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux @@ -0,0 +1,40 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + [collection + ["." dictionary] + ["." list]] + [text + ["%" format (#+ format)]]] + [target + ["_" r (#+ Var Expression)]]]] + ["." // #_ + ["#." common (#+ custom)] + ["//#" /// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" r #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with_vars)]]] + ["/#" // #_ + ["." generation] + ["//#" /// #_ + ["#." phase]]]]]]) + +(def: #export bundle + Bundle + (<| (/.prefix "r") + (|> /.empty + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux new file mode 100644 index 000000000..417ccf847 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux @@ -0,0 +1,18 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [ruby + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux new file mode 100644 index 000000000..4f2cd3291 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux @@ -0,0 +1,186 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary] + ["." list ("#\." functor fold)]]] + [math + [number + ["f" frac]]] + [target + ["_" ruby (#+ Expression)]]]] + ["." //// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" ruby #_ + ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]] + [// + [synthesis (#+ %synthesis)] + ["." generation] + [/// + ["#" phase]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension_name phase archive input') + + (#try.Failure error) + (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) + +## TODO: Get rid of this ASAP +(def: lux::syntax_char_case! + (..custom [($_ <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple ($_ <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension_name phase archive [input else conditionals]) + (do {! /////.monad} + [inputG (phase archive input) + elseG (phase archive else) + @input (\ ! map _.local (generation.gensym "input")) + conditionalsG (: (Operation (List [Expression Expression])) + (monad.map ! (function (_ [chars branch]) + (do ! + [branchG (phase archive branch)] + (wrap [(|> chars + (list\map (|>> .int _.int (_.= @input))) + (list\fold (function (_ clause total) + (if (is? _.nil total) + clause + (_.or clause total))) + _.nil)) + branchG]))) + conditionals)) + #let [closure (_.lambda #.None (list @input) + (list\fold (function (_ [test then] else) + (_.if test (_.return then) else)) + (_.return elseG) + conditionalsG))]] + (wrap (_.apply_lambda/* (list inputG) closure))))])) + +(def: lux_procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (function (_ [reference subject]) + (_.do "equal?" (list reference) subject)))) + (/.install "try" (unary //runtime.lux//try)))) + +(def: (capped operation parameter subject) + (-> (-> Expression Expression Expression) + (-> Expression Expression Expression)) + (//runtime.i64//64 (operation parameter subject))) + +(def: i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurry //runtime.i64//and))) + (/.install "or" (binary (product.uncurry //runtime.i64//or))) + (/.install "xor" (binary (product.uncurry //runtime.i64//xor))) + (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift))) + (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) + + (/.install "<" (binary (product.uncurry _.<))) + (/.install "=" (binary (product.uncurry _.=))) + (/.install "+" (binary (product.uncurry (..capped _.+)))) + (/.install "-" (binary (product.uncurry (..capped _.-)))) + (/.install "*" (binary (product.uncurry (..capped _.*)))) + (/.install "/" (binary (product.uncurry //runtime.i64//division))) + (/.install "%" (binary (function (_ [parameter subject]) + (_.do "remainder" (list parameter) subject)))) + + (/.install "f64" (unary (_./ (_.float +1.0)))) + (/.install "char" (unary (_.do "chr" (list (_.string "UTF-8"))))) + ))) + +(def: f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "+" (binary (product.uncurry _.+))) + (/.install "-" (binary (product.uncurry _.-))) + (/.install "*" (binary (product.uncurry _.*))) + (/.install "/" (binary (product.uncurry _./))) + (/.install "%" (binary (function (_ [parameter subject]) + (_.do "remainder" (list parameter) subject)))) + (/.install "=" (binary (product.uncurry _.=))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "i64" (unary (_.do "floor" (list)))) + (/.install "encode" (unary (_.do "to_s" (list)))) + (/.install "decode" (unary //runtime.f64//decode))))) + +(def: (text//char [subjectO paramO]) + (Binary Expression) + (//runtime.text//char subjectO paramO)) + +(def: (text//clip [paramO extraO subjectO]) + (Trinary Expression) + (//runtime.text//clip paramO extraO subjectO)) + +(def: (text//index [startO partO textO]) + (Trinary Expression) + (//runtime.text//index textO partO startO)) + +(def: text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurry _.=))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "concat" (binary (product.uncurry (function.flip _.+)))) + (/.install "index" (trinary text//index)) + (/.install "size" (unary (_.the "length"))) + (/.install "char" (binary (product.uncurry //runtime.text//char))) + (/.install "clip" (trinary text//clip)) + ))) + +(def: (io//log! messageG) + (Unary Expression) + (|> (_.print/2 messageG (_.string text.new_line)) + (_.or //runtime.unit))) + +(def: io//error! + (Unary Expression) + _.raise) + +(def: io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary ..io//log!)) + (/.install "error" (unary ..io//error!)) + ))) + +(def: #export bundle + Bundle + (<| (/.prefix "lux") + (|> lux_procs + (dictionary.merge ..i64_procs) + (dictionary.merge ..f64_procs) + (dictionary.merge ..text_procs) + (dictionary.merge ..io_procs) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux new file mode 100644 index 000000000..6f538b8dd --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux @@ -0,0 +1,136 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + [collection + ["." dictionary] + ["." list]] + [text + ["%" format (#+ format)]]] + [target + ["_" ruby (#+ Var Expression)]]]] + ["." // #_ + ["#." common (#+ custom)] + ["//#" /// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" ruby #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with_vars)]]] + ["/#" // #_ + ["." generation] + ["//#" /// #_ + ["#." phase]]]]]]) + +(def: (array::new [size]) + (Unary Expression) + (_.do "new" (list size) (_.local "Array"))) + +(def: array::length + (Unary Expression) + (_.the "size")) + +(def: (array::read [indexG arrayG]) + (Binary Expression) + (_.nth indexG arrayG)) + +(def: (array::write [indexG valueG arrayG]) + (Trinary Expression) + (//runtime.array//write indexG valueG arrayG)) + +(def: (array::delete [indexG arrayG]) + (Binary Expression) + (//runtime.array//write indexG _.nil arrayG)) + +(def: array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary array::length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(def: object::get + Handler + (custom + [($_ <>.and <s>.text <s>.any) + (function (_ extension phase archive [fieldS objectS]) + (do ////////phase.monad + [objectG (phase archive objectS)] + (wrap (_.the fieldS objectG))))])) + +(def: object::do + Handler + (custom + [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [methodS objectS inputsS]) + (do {! ////////phase.monad} + [objectG (phase archive objectS) + inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.do methodS inputsG objectG))))])) + +(template [<!> <?> <unit>] + [(def: <!> (Nullary Expression) (function.constant <unit>)) + (def: <?> (Unary Expression) (_.= <unit>))] + + [object::nil object::nil? _.nil] + ) + +(def: object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "get" object::get) + (/.install "do" object::do) + (/.install "nil" (nullary object::nil)) + (/.install "nil?" (unary object::nil?)) + ))) + +(def: ruby::constant + (custom + [<s>.text + (function (_ extension phase archive name) + (\ ////////phase.monad wrap (_.local name)))])) + +(def: ruby::apply + (custom + [($_ <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [abstractionS inputsS]) + (do {! ////////phase.monad} + [abstractionG (phase archive abstractionS) + inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.apply/* inputsG abstractionG))))])) + +(def: ruby::import + (custom + [<s>.text + (function (_ extension phase archive module) + (\ ////////phase.monad wrap + (_.require/1 (_.string module))))])) + +(def: #export bundle + Bundle + (<| (/.prefix "ruby") + (|> /.empty + (dictionary.merge ..array) + (dictionary.merge ..object) + + (/.install "constant" ruby::constant) + (/.install "apply" ruby::apply) + (/.install "import" ruby::import) + (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux new file mode 100644 index 000000000..7245ac4f6 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux @@ -0,0 +1,18 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [scheme + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux new file mode 100644 index 000000000..17df72ac2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux @@ -0,0 +1,175 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary] + ["." set] + ["." list ("#\." functor fold)]]] + [math + [number + ["f" frac]]] + ["@" target + ["_" scheme (#+ Expression)]]]] + ["." //// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" scheme #_ + ["#." runtime (#+ Operation Phase Handler Bundle Generator)] + ["#." case]]] + [// + ["." synthesis (#+ %synthesis)] + ["." generation] + [/// + ["#" phase]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension_name phase archive input') + + (#try.Failure error) + (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) + +(template: (!unary function) + (|>> list _.apply/* (|> (_.constant function)))) + +## TODO: Get rid of this ASAP +(def: lux::syntax_char_case! + (..custom [($_ <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple ($_ <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension_name phase archive [input else conditionals]) + (do {! /////.monad} + [@input (\ ! map _.var (generation.gensym "input")) + inputG (phase archive input) + elseG (phase archive else) + conditionalsG (: (Operation (List [Expression Expression])) + (monad.map ! (function (_ [chars branch]) + (do ! + [branchG (phase archive branch)] + (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or) + branchG]))) + conditionals))] + (wrap (_.let (list [@input inputG]) + (list\fold (function (_ [test then] else) + (_.if test then else)) + elseG + conditionalsG)))))])) + +(def: lux_procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (product.uncurry _.eq?/2))) + (/.install "try" (unary //runtime.lux//try)) + )) + +(def: (capped operation parameter subject) + (-> (-> Expression Expression Expression) + (-> Expression Expression Expression)) + (//runtime.i64//64 (operation parameter subject))) + +(def: i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurry //runtime.i64//and))) + (/.install "or" (binary (product.uncurry //runtime.i64//or))) + (/.install "xor" (binary (product.uncurry //runtime.i64//xor))) + (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift))) + (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) + (/.install "=" (binary (product.uncurry _.=/2))) + (/.install "<" (binary (product.uncurry _.</2))) + (/.install "+" (binary (product.uncurry (..capped _.+/2)))) + (/.install "-" (binary (product.uncurry (..capped _.-/2)))) + (/.install "*" (binary (product.uncurry (..capped _.*/2)))) + (/.install "/" (binary (product.uncurry //runtime.i64//division))) + (/.install "%" (binary (product.uncurry _.remainder/2))) + (/.install "f64" (unary (_.//2 (_.float +1.0)))) + (/.install "char" (unary (|>> _.integer->char/1 (_.make-string/2 (_.int +1))))) + ))) + +(def: f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "=" (binary (product.uncurry _.=/2))) + (/.install "<" (binary (product.uncurry _.</2))) + (/.install "+" (binary (product.uncurry _.+/2))) + (/.install "-" (binary (product.uncurry _.-/2))) + (/.install "*" (binary (product.uncurry _.*/2))) + (/.install "/" (binary (product.uncurry _.//2))) + (/.install "%" (binary (product.uncurry _.remainder/2))) + (/.install "i64" (unary _.truncate/1)) + (/.install "encode" (unary _.number->string/1)) + (/.install "decode" (unary //runtime.f64//decode))))) + +(def: (text//index [offset sub text]) + (Trinary Expression) + (//runtime.text//index offset sub text)) + +(def: (text//clip [paramO extraO subjectO]) + (Trinary Expression) + (//runtime.text//clip paramO extraO subjectO)) + +(def: text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurry _.string=?/2))) + (/.install "<" (binary (product.uncurry _.string<?/2))) + (/.install "concat" (binary (product.uncurry _.string-append/2))) + (/.install "index" (trinary ..text//index)) + (/.install "size" (unary _.string-length/1)) + (/.install "char" (binary (product.uncurry //runtime.text//char))) + (/.install "clip" (trinary ..text//clip)) + ))) + +(def: (io//log! message) + (Unary Expression) + (_.begin (list (_.display/1 message) + (_.display/1 (_.string text.new_line)) + //runtime.unit))) + +(def: io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary ..io//log!)) + (/.install "error" (unary _.raise/1)) + ))) + +(def: #export bundle + Bundle + (<| (/.prefix "lux") + (|> /.empty + (dictionary.merge lux_procs) + (dictionary.merge i64_procs) + (dictionary.merge f64_procs) + (dictionary.merge text_procs) + (dictionary.merge io_procs) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux new file mode 100644 index 000000000..e67e05db4 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux @@ -0,0 +1,109 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + [collection + ["." dictionary] + ["." list]] + [text + ["%" format (#+ format)]]] + [target + ["_" scheme (#+ Var Expression)]]]] + ["." // #_ + ["#." common (#+ custom)] + ["//#" /// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" scheme #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with_vars)]]] + ["/#" // #_ + ["." generation] + ["//#" /// #_ + ["#." phase]]]]]]) + +(def: (array::new size) + (Unary Expression) + (_.make-vector/2 size _.nil)) + +(def: array::length + (Unary Expression) + _.vector-length/1) + +(def: (array::read [indexG arrayG]) + (Binary Expression) + (_.vector-ref/2 arrayG indexG)) + +(def: (array::write [indexG valueG arrayG]) + (Trinary Expression) + (//runtime.array//write indexG valueG arrayG)) + +(def: (array::delete [indexG arrayG]) + (Binary Expression) + (//runtime.array//write indexG _.nil arrayG)) + +(def: array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary array::length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(template [<!> <?> <unit>] + [(def: <!> (Nullary Expression) (function.constant <unit>)) + (def: <?> (Unary Expression) (_.eq?/2 <unit>))] + + [object::nil object::nil? _.nil] + ) + +(def: object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "nil" (nullary object::nil)) + (/.install "nil?" (unary object::nil?)) + ))) + +(def: scheme::constant + (custom + [<s>.text + (function (_ extension phase archive name) + (do ////////phase.monad + [] + (wrap (_.var name))))])) + +(def: scheme::apply + (custom + [($_ <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [abstractionS inputsS]) + (do {! ////////phase.monad} + [abstractionG (phase archive abstractionS) + inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.apply/* inputsG abstractionG))))])) + +(def: #export bundle + Bundle + (<| (/.prefix "scheme") + (|> /.empty + (dictionary.merge ..array) + (dictionary.merge ..object) + + (/.install "constant" scheme::constant) + (/.install "apply" scheme::apply) + (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/synthesis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/synthesis.lux new file mode 100644 index 000000000..7e9e85d6e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/synthesis.lux @@ -0,0 +1,11 @@ +(.module: + [library + [lux #*]] + [// + ["." bundle] + [/// + [synthesis (#+ Bundle)]]]) + +(def: #export bundle + Bundle + bundle.empty) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux new file mode 100644 index 000000000..972e318c2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux @@ -0,0 +1,57 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]]]] + ["." / #_ + [runtime (#+ Phase)] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." loop] + ["#." function] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + [analysis (#+)] + ["#." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) + +(def: #export (generate archive synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + [(^ (<tag> value)) + (//////phase\wrap (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + (#////synthesis.Reference value) + (//reference.reference /reference.system archive value) + + (^template [<tag> <generator>] + [(^ (<tag> value)) + (<generator> generate archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + [////synthesis.function/apply /function.apply] + + [////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.loop/recur /loop.recur] + [////synthesis.function/abstraction /function.function]) + + (#////synthesis.Extension extension) + (///extension.apply archive generate extension) + )) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux new file mode 100644 index 000000000..2425e2cb4 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux @@ -0,0 +1,262 @@ +(.module: + [library + [lux (#- case let if) + [abstract + ["." monad (#+ do)]] + [control + ["." exception (#+ exception:)]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold monoid)] + ["." set]]] + [math + [number + ["n" nat]]] + [target + ["_" common_lisp (#+ Expression Var/1)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] + ["#." primitive] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." synthesis #_ + ["#/." case]] + ["/#" // #_ + ["#." synthesis (#+ Member Synthesis Path)] + ["#." generation] + ["//#" /// #_ + [reference + ["#." variable (#+ Register)]] + ["#." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]]) + +(def: #export register + (-> Register Var/1) + (|>> (///reference.local //reference.system) :assume)) + +(def: #export capture + (-> Register Var/1) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: #export (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueG (expression archive valueS) + bodyG (expression archive bodyS)] + (wrap (_.let (list [(..register register) valueG]) + (list bodyG))))) + +(def: #export (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testG (expression archive testS) + thenG (expression archive thenS) + elseG (expression archive elseS)] + (wrap (_.if testG thenG elseG)))) + +(def: #export (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueG (expression archive valueS)] + (wrap (list\fold (function (_ side source) + (.let [method (.case side + (^template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.int (.int lefts)))]) + ([#.Left //runtime.tuple//left] + [#.Right //runtime.tuple//right]))] + (method source))) + valueG + pathP)))) + +(def: @savepoint (_.var "lux_pm_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) +(def: @variant (_.var "lux_pm_variant")) + +(def: (push! value) + (-> (Expression Any) (Expression Any)) + (_.setq @cursor (_.cons/2 [value @cursor]))) + +(def: pop! + (Expression Any) + (_.setq @cursor (_.cdr/1 @cursor))) + +(def: peek + (Expression Any) + (_.car/1 @cursor)) + +(def: save! + (Expression Any) + (_.setq @savepoint (_.cons/2 [@cursor @savepoint]))) + +(def: restore! + (List (Expression Any)) + (list (_.setq @cursor (_.car/1 @savepoint)) + (_.setq @savepoint (_.cdr/1 @savepoint)))) + +(def: (multi_pop! pops) + (-> Nat (Expression Any)) + (_.setq @cursor (_.nthcdr/2 [(_.int (.int pops)) @cursor]))) + +(template [<name> <flag> <prep>] + [(def: (<name> @fail simple? idx next!) + (-> _.Tag Bit Nat (Maybe (Expression Any)) (Expression Any)) + (.let [<failure_condition> (_.eq/2 [@variant @temp])] + (_.let (list [@variant ..peek]) + (list& (_.setq @temp (|> idx <prep> .int _.int (//runtime.sum//get @variant <flag>))) + (.if simple? + (_.when <failure_condition> + (_.go @fail)) + (_.if <failure_condition> + (_.go @fail) + (..push! @temp))) + (.case next! + (#.Some next!) + (list next!) + + #.None + (list))))))] + + [left_choice _.nil (<|)] + [right_choice (_.string "") inc] + ) + +(def: (alternation @otherwise pre! post!) + (-> _.Tag (Expression Any) (Expression Any) (Expression Any)) + (_.tagbody ($_ list\compose + (list ..save! + pre! + @otherwise) + ..restore! + (list post!)))) + +(def: (pattern_matching' expression archive) + (Generator [Var/1 _.Tag _.Tag Path]) + (function (recur [$output @done @fail pathP]) + (.case pathP + (^ (/////synthesis.path/then bodyS)) + (\ ///////phase.monad map + (function (_ outputV) + (_.progn (list (_.setq $output outputV) + (_.go @done)))) + (expression archive bodyS)) + + #/////synthesis.Pop + (///////phase\wrap ..pop!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.setq (..register register) ..peek)) + + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur [$output @done @fail thenP]) + else! (.case elseP + (#.Some elseP) + (recur [$output @done @fail elseP]) + + #.None + (wrap (_.go @fail)))] + (wrap (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^template [<tag> <format> <=>] + [(<tag> cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (do ! + [then! (recur [$output @done @fail then])] + (wrap [(<=> [(|> match <format>) + ..peek]) + then!]))) + (#.Cons cons))] + (wrap (list\fold (function (_ [when then] else) + (_.if when then else)) + (_.go @fail) + clauses)))]) + ([#/////synthesis.I64_Fork //primitive.i64 _.=/2] + [#/////synthesis.F64_Fork //primitive.f64 _.=/2] + [#/////synthesis.Text_Fork //primitive.text _.string=/2]) + + (^template [<complex> <simple> <choice>] + [(^ (<complex> idx)) + (///////phase\wrap (<choice> @fail false idx #.None)) + + (^ (<simple> idx nextP)) + (|> nextP + [$output @done @fail] recur + (\ ///////phase.monad map (|>> #.Some (<choice> @fail true idx))))]) + ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] + [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (..push! (_.elt/2 [..peek (_.int +0)]))) + + (^template [<pm> <getter>] + [(^ (<pm> lefts)) + (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^ (/////synthesis.!multi_pop nextP)) + (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)] + (do ///////phase.monad + [next! (recur [$output @done @fail nextP'])] + (///////phase\wrap (_.progn (list (..multi_pop! (n.+ 2 extra_pops)) + next!))))) + + (^ (/////synthesis.path/alt preP postP)) + (do {! ///////phase.monad} + [@otherwise (\ ! map (|>> %.nat (format "lux_case_otherwise") _.tag) /////generation.next) + pre! (recur [$output @done @otherwise preP]) + post! (recur [$output @done @fail postP])] + (wrap (..alternation @otherwise pre! post!))) + + (^ (/////synthesis.path/seq preP postP)) + (do ///////phase.monad + [pre! (recur [$output @done @fail preP]) + post! (recur [$output @done @fail postP])] + (wrap (_.progn (list pre! post!))))))) + +(def: (pattern_matching $output expression archive pathP) + (-> Var/1 (Generator Path)) + (do {! ///////phase.monad} + [@done (\ ! map (|>> %.nat (format "lux_case_done") _.tag) /////generation.next) + @fail (\ ! map (|>> %.nat (format "lux_case_fail") _.tag) /////generation.next) + pattern_matching! (pattern_matching' expression archive [$output @done @fail pathP])] + (wrap (_.tagbody + (list pattern_matching! + @fail + (_.error/1 (_.string ////synthesis/case.pattern_matching_error)) + @done))))) + +(def: #export (case expression archive [valueS pathP]) + (Generator [Synthesis Path]) + (do {! ///////phase.monad} + [initG (expression archive valueS) + $output (\ ! map (|>> %.nat (format "lux_case_output") _.var) /////generation.next) + pattern_matching! (pattern_matching $output expression archive pathP) + #let [storage (|> pathP + ////synthesis/case.storage + (get@ #////synthesis/case.bindings) + set.to_list + (list\map (function (_ register) + [(..register register) + _.nil])))]] + (wrap (_.let (list& [@cursor (_.list/* (list initG))] + [@savepoint (_.list/* (list))] + [@temp _.nil] + [$output _.nil] + storage) + (list pattern_matching! + $output))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux new file mode 100644 index 000000000..1880d7700 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux @@ -0,0 +1,14 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common]]) + +(def: #export bundle + Bundle + common.bundle) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux new file mode 100644 index 000000000..baac3e891 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux @@ -0,0 +1,137 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function]] + [data + ["." product] + [number + ["f" frac]] + [collection + ["." dictionary]]] + [target + ["_" common-lisp (#+ Expression)]]]] + ["." /// #_ + ["#." runtime (#+ Operation Phase Handler Bundle)] + ["#." primitive] + [// + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + [// + [extension + ["." bundle]]]]]) + +(def: lux-procs + Bundle + (|> bundle.empty + (bundle.install "is" (binary (product.uncurry _.eq))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(def: (i64//left-shift [paramG subjectG]) + (Binary (Expression Any)) + (_.ash (_.rem (_.int +64) paramG) subjectG)) + +(def: (i64//arithmetic-right-shift [paramG subjectG]) + (Binary (Expression Any)) + (_.ash (|> paramG (_.rem (_.int +64)) (_.* (_.int -1))) + subjectG)) + +(def: (i64//logic-right-shift [paramG subjectG]) + (Binary (Expression Any)) + (///runtime.i64//logic-right-shift (_.rem (_.int +64) paramG) subjectG)) + +(def: i64-procs + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary (product.uncurry _.logand))) + (bundle.install "or" (binary (product.uncurry _.logior))) + (bundle.install "xor" (binary (product.uncurry _.logxor))) + (bundle.install "left-shift" (binary i64//left-shift)) + (bundle.install "logical-right-shift" (binary i64//logic-right-shift)) + (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift)) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _.floor))) + (bundle.install "%" (binary (product.uncurry _.rem))) + (bundle.install "f64" (unary (function (_ value) + (_.coerce/2 [value (_.symbol "double-float")])))) + (bundle.install "char" (unary (|>> _.code-char/1 _.string/1))) + ))) + +(def: f64-procs + Bundle + (<| (bundle.prefix "f64") + (|> bundle.empty + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.mod))) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "i64" (unary _.floor/1)) + (bundle.install "encode" (unary _.write-to-string/1)) + (bundle.install "decode" (unary (let [@temp (_.var "temp")] + (function (_ input) + (_.let (list [@temp (_.read-from-string/1 input)]) + (_.if (_.equal (_.symbol "DOUBLE-FLOAT") + (_.type-of/1 @temp)) + (///runtime.some @temp) + ///runtime.none))))))))) + +(def: (text//< [paramG subjectG]) + (Binary (Expression Any)) + (|> (_.string< paramG subjectG) + _.null/1 + _.not/1)) + +(def: (text//clip [paramO extraO subjectO]) + (Trinary (Expression Any)) + (///runtime.text//clip subjectO paramO extraO)) + +(def: (text//index [startO partO textO]) + (Trinary (Expression Any)) + (///runtime.text//index textO partO startO)) + +(def: text-procs + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary (product.uncurry _.string=))) + (bundle.install "<" (binary text//<)) + (bundle.install "concat" (binary _.concatenate/2|string)) + (bundle.install "index" (trinary text//index)) + (bundle.install "size" (unary _.length/1)) + (bundle.install "char" (binary (|>> _.char/2 _.char-int/1))) + (bundle.install "clip" (trinary text//clip)) + ))) + +(def: (void code) + (-> (Expression Any) (Expression Any)) + ($_ _.progn + code + ///runtime.unit)) + +(def: io-procs + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary (|>> _.print/1 ..void))) + (bundle.install "error" (unary _.error/1)) + ))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> lux-procs + (dictionary.merge i64-procs) + (dictionary.merge f64-procs) + (dictionary.merge text-procs) + (dictionary.merge io-procs) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux new file mode 100644 index 000000000..6adc2d747 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux @@ -0,0 +1,103 @@ +(.module: + [library + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + pipe] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [target + ["_" common_lisp (#+ Expression Var/1)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] + ["#." case] + ["/#" // #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant Tuple Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["#." generation (#+ Context)] + ["//#" /// #_ + [arity (#+ Arity)] + ["#." phase ("#\." monad)] + [reference + [variable (#+ Register Variable)]]]]]]) + +(def: #export (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do {! ///////phase.monad} + [functionG (expression archive functionS) + argsG+ (monad.map ! (expression archive) argsS+)] + (wrap (_.funcall/+ [functionG argsG+])))) + +(def: capture + (-> Register Var/1) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: (with_closure inits function_definition) + (-> (List (Expression Any)) (Expression Any) (Operation (Expression Any))) + (case inits + #.Nil + (\ ///////phase.monad wrap function_definition) + + _ + (do {! ///////phase.monad} + [@closure (\ ! map _.var (/////generation.gensym "closure"))] + (wrap (_.labels (list [@closure [(|> (list.enumeration inits) + (list\map (|>> product.left ..capture)) + _.args) + function_definition]]) + (_.funcall/+ [(_.function/1 @closure) inits])))))) + +(def: input + (|>> inc //case.register)) + +(def: #export (function expression archive [environment arity bodyS]) + (Generator (Abstraction Synthesis)) + (do {! ///////phase.monad} + [@scope (\ ! map (|>> %.nat (format "function_scope") _.tag) /////generation.next) + @output (\ ! map (|>> %.nat (format "loop_output") _.var) /////generation.next) + [function_name bodyG] (/////generation.with_new_context archive + (/////generation.with_anchor [@scope 1] + (expression archive bodyS))) + closureG+ (monad.map ! (expression archive) environment) + #let [@curried (_.var "curried") + @missing (_.var "missing") + arityG (|> arity .int _.int) + @num_args (_.var "num_args") + @self (_.var (///reference.artifact function_name)) + initialize_self! [(//case.register 0) (_.function/1 @self)] + initialize! [(|> (list.indices arity) + (list\map ..input) + _.args) + @curried]]] + (with_closure closureG+ + (_.labels (list [@self [(_.args& (list) @curried) + (_.let (list [@num_args (_.length/1 @curried)]) + (list (_.cond (list [(_.=/2 [arityG @num_args]) + (_.let (list [@output _.nil] + initialize_self!) + (list (_.destructuring-bind initialize! + (list (_.tagbody + (list @scope + (_.setq @output bodyG))) + @output))))] + + [(_.>/2 [arityG @num_args]) + (let [arity_inputs (_.subseq/3 [@curried (_.int +0) arityG]) + extra_inputs (_.subseq/3 [@curried arityG @num_args])] + (_.apply/2 [(_.apply/2 [(_.function/1 @self) + arity_inputs]) + extra_inputs]))]) + ## (|> @num_args (_.< arityG)) + (_.lambda (_.args& (list) @missing) + (_.apply/2 [(_.function/1 @self) + (_.append/2 [@curried @missing])])))))]]) + (_.function/1 @self))) + )) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux new file mode 100644 index 000000000..bfe5e2787 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux @@ -0,0 +1,70 @@ +(.module: + [library + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)]]] + [math + [number + ["n" nat]]] + [target + ["_" common_lisp (#+ Expression)]]]] + ["." // #_ + [runtime (#+ Operation Phase Generator)] + ["#." case] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + [synthesis + ["." case]] + ["/#" // #_ + ["."synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [meta + [archive (#+ Archive)]] + [reference + [variable (#+ Register)]]]]]]]) + +(def: #export (scope expression archive [start initsS+ bodyS]) + (Generator (Scope Synthesis)) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [@scope (\ ! map (|>> %.nat (format "loop_scope") _.tag) /////generation.next) + @output (\ ! map (|>> %.nat (format "loop_output") _.var) /////generation.next) + initsG+ (monad.map ! (expression archive) initsS+) + bodyG (/////generation.with_anchor [@scope start] + (expression archive bodyS))] + (wrap (_.let (|> initsG+ + list.enumeration + (list\map (function (_ [idx init]) + [(|> idx (n.+ start) //case.register) + init])) + (list& [@output _.nil])) + (list (_.tagbody (list @scope + (_.setq @output bodyG))) + @output)))))) + +(def: #export (recur expression archive argsS+) + (Generator (List Synthesis)) + (do {! ///////phase.monad} + [[tag offset] /////generation.anchor + argsO+ (monad.map ! (expression archive) argsS+) + #let [bindings (|> argsO+ + list.enumeration + (list\map (|>> product.left (n.+ offset) //case.register)) + _.args)]] + (wrap (_.progn (list (_.multiple-value-setq bindings (_.values/* argsO+)) + (_.go tag)))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux new file mode 100644 index 000000000..82ab68128 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux @@ -0,0 +1,21 @@ +(.module: + [library + [lux (#- i64) + [target + ["_" common_lisp (#+ Expression)]]]]) + +(def: #export bit + (-> Bit (Expression Any)) + _.bool) + +(def: #export i64 + (-> (I64 Any) (Expression Any)) + (|>> .int _.int)) + +(def: #export f64 + (-> Frac (Expression Any)) + _.double) + +(def: #export text + (-> Text (Expression Any)) + _.string) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux new file mode 100644 index 000000000..83bbc6a95 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" common_lisp (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System (Expression Any)) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux new file mode 100644 index 000000000..41e7cda43 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux @@ -0,0 +1,293 @@ +(.module: + [library + [lux (#- Location inc) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<.>" code]]] + [data + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + ["." encoding]] + [collection + ["." list ("#\." functor monoid)] + ["." row]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["." i64]]] + ["@" target + ["_" common_lisp (#+ Expression Computation Literal)]]]] + ["." /// #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant)] + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// + ["#." phase] + [reference + [variable (#+ Register)]] + [meta + [archive (#+ Output Archive) + ["." artifact (#+ Registry)]]]]]]) + +(def: module_id + 0) + +(template [<name> <base>] + [(type: #export <name> + (<base> [_.Tag Register] (Expression Any) (Expression Any)))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type: #export (Generator i) + (-> Phase Archive i (Operation (Expression Any)))) + +(def: #export unit + (_.string /////synthesis.unit)) + +(def: (flag value) + (-> Bit Literal) + (if value + (_.string "") + _.nil)) + +(def: (variant' tag last? value) + (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) + (_.list/* (list tag last? value))) + +(def: #export (variant [lefts right? value]) + (-> (Variant (Expression Any)) (Computation Any)) + (variant' (_.int (.int lefts)) (flag right?) value)) + +(def: #export none + (Computation Any) + (|> ..unit [0 #0] ..variant)) + +(def: #export some + (-> (Expression Any) (Computation Any)) + (|>> [1 #1] ..variant)) + +(def: #export left + (-> (Expression Any) (Computation Any)) + (|>> [0 #0] ..variant)) + +(def: #export right + (-> (Expression Any) (Computation Any)) + (|>> [1 #1] ..variant)) + +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} + body) + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} + code) + (do meta.monad + [runtime_id meta.count] + (macro.with_gensyms [g!_] + (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.var (~ (code.text (%.code runtime)))))] + (case declaration + (#.Left name) + (let [g!name (code.local_identifier name) + code_nameC (code.local_identifier (format "@" name))] + (wrap (list (` (def: #export (~ g!name) + _.Var/1 + (~ runtime_name))) + + (` (def: (~ code_nameC) + (_.Expression Any) + (_.defparameter (~ runtime_name) (~ code))))))) + + (#.Right [name inputs]) + (let [g!name (code.local_identifier name) + code_nameC (code.local_identifier (format "@" name)) + + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` (_.Expression Any))) + inputs)] + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) + (-> (~+ inputs_typesC) (_.Computation Any)) + (_.call/* (~ runtime_name) (list (~+ inputsC))))) + + (` (def: (~ code_nameC) + (_.Expression Any) + (..with_vars [(~+ inputsC)] + (_.defun (~ runtime_name) (_.args (list (~+ inputsC))) + (~ code))))))))))))) + +(runtime: (lux//try op) + (with_vars [error] + (_.handler-case + (list [(_.bool true) error + (..left (_.format/3 [_.nil (_.string "~A") error]))]) + (..right (_.funcall/+ [op (list ..unit)]))))) + +## TODO: Use Common Lisp's swiss-army loop macro instead. +(runtime: (lux//program_args inputs) + (with_vars [loop input tail] + (_.labels (list [loop [(_.args (list input tail)) + (_.if (_.null/1 input) + tail + (_.funcall/+ [(_.function/1 loop) + (list (_.cdr/1 input) + (..some (_.vector/* (list (_.car/1 input) tail))))]))]]) + (_.funcall/+ [(_.function/1 loop) + (list (_.reverse/1 inputs) + ..none)])))) + +(def: runtime//lux + (List (Expression Any)) + (list @lux//try + @lux//program_args)) + +(def: last_index + (|>> _.length/1 [(_.int +1)] _.-/2)) + +(with_expansions [<recur> (as_is ($_ _.then + (_.; (_.set lefts (_.-/2 [last_index_right lefts]))) + (_.; (_.set tuple (_.nth last_index_right tuple)))))] + (template: (!recur <side>) + (<side> (_.-/2 [last_index_right lefts]) + (_.elt/2 [tuple last_index_right]))) + + (runtime: (tuple//left lefts tuple) + (with_vars [last_index_right] + (_.let (list [last_index_right (..last_index tuple)]) + (list (_.if (_.>/2 [lefts last_index_right]) + ## No need for recursion + (_.elt/2 [tuple lefts]) + ## Needs recursion + (!recur tuple//left)))))) + + (runtime: (tuple//right lefts tuple) + (with_vars [last_index_right right_index] + (_.let (list [last_index_right (..last_index tuple)] + [right_index (_.+/2 [(_.int +1) lefts])]) + (list (_.cond (list [(_.=/2 [last_index_right right_index]) + (_.elt/2 [tuple right_index])] + [(_.>/2 [last_index_right right_index]) + ## Needs recursion. + (!recur tuple//right)]) + (_.subseq/3 [tuple right_index (_.length/1 tuple)]))))))) + +## TODO: Find a way to extract parts of the sum without "nth", which +## does a linear search, and is thus expensive. +(runtime: (sum//get sum wantsLast wantedTag) + (with_vars [sum_tag sum_flag] + (let [no_match! (_.return sum) + sum_value (_.nth/2 [(_.int +2) sum]) + test_recursion! (_.if sum_flag + ## Must iterate. + (_.progn (list (_.setq wantedTag (_.-/2 [sum_tag wantedTag])) + (_.setq sum sum_value))) + no_match!)] + (_.while (_.bool true) + (_.let (list [sum_tag (_.nth/2 [(_.int +0) sum])] + [sum_flag (_.nth/2 [(_.int +1) sum])]) + (list (_.cond (list [(_.=/2 [sum_tag wantedTag]) + (_.if (_.equal/2 [wantsLast sum_flag]) + (_.return sum_value) + test_recursion!)] + + [(_.>/2 [sum_tag wantedTag]) + test_recursion!] + + [(_.and (_.</2 [sum_tag wantedTag]) + wantsLast) + (_.return (variant' (_.-/2 [wantedTag sum_tag]) sum_flag sum_value))]) + + no_match!))))))) + +(def: runtime//adt + (List (Expression Any)) + (list @tuple//left + @tuple//right + @sum//get)) + +(runtime: (i64//right_shift shift input) + (_.if (_.=/2 [(_.int +0) shift]) + input + (let [anti_shift (_.-/2 [shift (_.int +64)]) + mask (|> (_.int +1) + [anti_shift] _.ash/2 + [(_.int +1)] _.-/2)] + (|> input + [(_.*/2 [(_.int -1) shift])] _.ash/2 + [mask] _.logand/2)))) + +(def: runtime//i64 + (List (Expression Any)) + (list @i64//right_shift)) + +(runtime: (text//clip offset length text) + (_.subseq/3 [text offset (_.+/2 [offset length])])) + +(runtime: (text//index offset sub text) + (with_vars [index] + (_.let (list [index (_.search/3 [sub text offset])]) + (list (_.if index + (..some index) + ..none))))) + +(def: runtime//text + (List (Expression Any)) + (list @text//index + @text//clip)) + +(runtime: (io//exit code) + (_.progn (list (_.conditional+ (list "sbcl") + (_.call/* (_.var "sb-ext:quit") (list code))) + (_.conditional+ (list "clisp") + (_.call/* (_.var "ext:exit") (list code))) + (_.conditional+ (list "ccl") + (_.call/* (_.var "ccl:quit") (list code))) + (_.conditional+ (list "allegro") + (_.call/* (_.var "excl:exit") (list code))) + (_.call/* (_.var "cl-user::quit") (list code))))) + +(def: runtime//io + (List (Expression Any)) + (list @io//exit)) + +(def: runtime + (_.progn ($_ list\compose + runtime//adt + runtime//lux + runtime//i64 + runtime//text + runtime//io))) + +(def: #export generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! (%.nat ..module_id) ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row [(%.nat ..module_id) + (|> ..runtime + _.code + (\ encoding.utf8 encode))])]))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux new file mode 100644 index 000000000..44bd542f6 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux @@ -0,0 +1,37 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [target + ["_" common_lisp (#+ Expression)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." primitive] + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + ["//#" /// #_ + ["#." phase ("#\." monad)]]]]) + +(def: #export (tuple expression archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + #.Nil + (///////phase\wrap (//primitive.text /////synthesis.unit)) + + (#.Cons singletonS #.Nil) + (expression archive singletonS) + + _ + (|> elemsS+ + (monad.map ///////phase.monad (expression archive)) + (///////phase\map _.vector/*)))) + +(def: #export (variant expression archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (inc lefts) + lefts)] + (///////phase\map (|>> [tag right?] //runtime.variant) + (expression archive valueS)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux new file mode 100644 index 000000000..5196c6e33 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux @@ -0,0 +1,66 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + [parser + ["s" code]]] + [data + [collection + ["." list ("#\." functor)]]] + ["." meta] + ["." macro (#+ with_gensyms) + ["." code] + [syntax (#+ syntax:)]]]] + ["." /// #_ + ["#." extension] + [// + [synthesis (#+ Synthesis)] + ["." generation] + [/// + ["#" phase]]]]) + +(syntax: (Vector {size s.nat} elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export (Nullary of) (-> (Vector 0 of) of)) +(type: #export (Unary of) (-> (Vector 1 of) of)) +(type: #export (Binary of) (-> (Vector 2 of) of)) +(type: #export (Trinary of) (-> (Vector 3 of) of)) +(type: #export (Variadic of) (-> (List of) of)) + +(syntax: (arity: {arity s.nat} {name s.local_identifier} type) + (with_gensyms [g!_ g!extension g!name g!phase g!archive g!inputs g!of g!anchor g!expression g!directive] + (do {! meta.monad} + [g!input+ (monad.seq ! (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local_identifier name)) (~ g!extension)) + (All [(~ g!anchor) (~ g!expression) (~ g!directive)] + (-> ((~ type) (~ g!expression)) + (generation.Handler (~ g!anchor) (~ g!expression) (~ g!directive)))) + (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!archive) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do ///.monad + [(~+ (|> g!input+ + (list\map (function (_ g!input) + (list g!input (` ((~ g!phase) (~ g!archive) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) + + (~' _) + (///.throw ///extension.incorrect_arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) + +(arity: 0 nullary ..Nullary) +(arity: 1 unary ..Unary) +(arity: 2 binary ..Binary) +(arity: 3 trinary ..Trinary) + +(def: #export (variadic extension) + (All [anchor expression directive] + (-> (Variadic expression) (generation.Handler anchor expression directive))) + (function (_ extension_name) + (function (_ phase archive inputsS) + (do {! ///.monad} + [inputsI (monad.map ! (phase archive) inputsS)] + (wrap (extension inputsI)))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js.lux new file mode 100644 index 000000000..18319d0a2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js.lux @@ -0,0 +1,117 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." exception (#+ exception:)]] + [target + ["_" js]]]] + ["." / #_ + [runtime (#+ Phase Phase!)] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." loop] + ["#." function] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + [analysis (#+)] + ["." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) + +(def: (statement expression archive synthesis) + Phase! + (case synthesis + (^template [<tag>] + [(^ (<tag> value)) + (//////phase\map _.return (expression archive synthesis))]) + ([synthesis.bit] + [synthesis.i64] + [synthesis.f64] + [synthesis.text] + [synthesis.variant] + [synthesis.tuple] + [#synthesis.Reference] + [synthesis.branch/get] + [synthesis.function/apply] + [#synthesis.Extension]) + + (^ (synthesis.branch/case case)) + (/case.case! statement expression archive case) + + (^ (synthesis.branch/let let)) + (/case.let! statement expression archive let) + + (^ (synthesis.branch/if if)) + (/case.if! statement expression archive if) + + (^ (synthesis.loop/scope scope)) + (/loop.scope! statement expression archive scope) + + (^ (synthesis.loop/recur updates)) + (/loop.recur! statement expression archive updates) + + (^ (synthesis.function/abstraction abstraction)) + (//////phase\map _.return (/function.function statement expression archive abstraction)) + )) + +(exception: #export cannot-recur-as-an-expression) + +(def: (expression archive synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + [(^ (<tag> value)) + (//////phase\wrap (<generator> value))]) + ([synthesis.bit /primitive.bit] + [synthesis.i64 /primitive.i64] + [synthesis.f64 /primitive.f64] + [synthesis.text /primitive.text]) + + (^ (synthesis.variant variantS)) + (/structure.variant expression archive variantS) + + (^ (synthesis.tuple members)) + (/structure.tuple expression archive members) + + (#synthesis.Reference value) + (//reference.reference /reference.system archive value) + + (^ (synthesis.branch/case case)) + (/case.case ..statement expression archive case) + + (^ (synthesis.branch/let let)) + (/case.let expression archive let) + + (^ (synthesis.branch/if if)) + (/case.if expression archive if) + + (^ (synthesis.branch/get get)) + (/case.get expression archive get) + + (^ (synthesis.loop/scope scope)) + (/loop.scope ..statement expression archive scope) + + (^ (synthesis.loop/recur updates)) + (//////phase.throw ..cannot-recur-as-an-expression []) + + (^ (synthesis.function/abstraction abstraction)) + (/function.function ..statement expression archive abstraction) + + (^ (synthesis.function/apply application)) + (/function.apply expression archive application) + + (#synthesis.Extension extension) + (///extension.apply archive expression extension))) + +(def: #export generate + Phase + ..expression) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/case.lux new file mode 100644 index 000000000..76da7c8f1 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/case.lux @@ -0,0 +1,322 @@ +(.module: + [library + [lux (#- case let if) + [abstract + ["." monad (#+ do)]] + [data + ["." maybe] + ["." text] + [collection + ["." list ("#\." functor fold)]]] + [math + [number + ["n" nat]]] + [target + ["_" js (#+ Expression Computation Var Statement)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Phase! Generator Generator!)] + ["#." reference] + ["#." primitive] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." synthesis #_ + ["#/." case]] + ["/#" // #_ + ["#." synthesis (#+ Member Synthesis Path)] + ["//#" /// #_ + [reference + [variable (#+ Register)]] + ["#." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]]) + +(def: #export register + (-> Register Var) + (|>> (///reference.local //reference.system) :assume)) + +(def: #export (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + ## TODO: Find some way to do 'let' without paying the price of the closure. + (wrap (_.apply/* (_.closure (list (..register register)) + (_.return bodyO)) + (list valueO))))) + +(def: #export (let! statement expression archive [valueS register bodyS]) + (Generator! [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (statement expression archive bodyS)] + (wrap ($_ _.then + (_.define (..register register) valueO) + bodyO)))) + +(def: #export (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (wrap (_.? testO thenO elseO)))) + +(def: #export (if! statement expression archive [testS thenS elseS]) + (Generator! [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (statement expression archive thenS) + elseO (statement expression archive elseS)] + (wrap (_.if testO + thenO + elseO)))) + +(def: #export (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (wrap (list\fold (function (_ side source) + (.let [method (.case side + (^template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.i32 (.int lefts)))]) + ([#.Left //runtime.tuple//left] + [#.Right //runtime.tuple//right]))] + (method source))) + valueO + (list.reverse pathP))))) + +(def: @savepoint (_.var "lux_pm_cursor_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) + +(def: (push_cursor! value) + (-> Expression Statement) + (_.statement (|> @cursor (_.do "push" (list value))))) + +(def: peek_and_pop_cursor + Expression + (|> @cursor (_.do "pop" (list)))) + +(def: pop_cursor! + Statement + (_.statement ..peek_and_pop_cursor)) + +(def: length + (|>> (_.the "length"))) + +(def: last_index + (|>> ..length (_.- (_.i32 +1)))) + +(def: peek_cursor + Expression + (|> @cursor (_.at (last_index @cursor)))) + +(def: save_cursor! + Statement + (.let [cursor (|> @cursor (_.do "slice" (list)))] + (_.statement (|> @savepoint (_.do "push" (list cursor)))))) + +(def: restore_cursor! + Statement + (_.set @cursor (|> @savepoint (_.do "pop" (list))))) + +(def: fail_pm! _.break) + +(def: (multi_pop_cursor! pops) + (-> Nat Statement) + (.let [popsJS (_.i32 (.int pops))] + (_.statement (|> @cursor (_.do "splice" (list (|> @cursor ..length (_.- popsJS)) + popsJS)))))) + +(template [<name> <flag> <prep>] + [(def: (<name> simple? idx) + (-> Bit Nat Statement) + ($_ _.then + (_.set @temp (|> idx <prep> .int _.i32 (//runtime.sum//get ..peek_cursor <flag>))) + (.if simple? + (_.when (_.= _.null @temp) + ..fail_pm!) + (_.if (_.= _.null @temp) + ..fail_pm! + (push_cursor! @temp)))))] + + [left_choice _.null (<|)] + [right_choice (_.string "") inc] + ) + +(def: (alternation pre! post!) + (-> Statement Statement Statement) + ($_ _.then + (_.do_while (_.boolean false) + ($_ _.then + ..save_cursor! + pre!)) + ($_ _.then + ..restore_cursor! + post!))) + +(def: (optimized_pattern_matching recur pathP) + (-> (-> Path (Operation Statement)) + (-> Path (Operation (Maybe Statement)))) + (.case pathP + (^template [<simple> <choice>] + [(^ (<simple> idx nextP)) + (|> nextP + recur + (\ ///////phase.monad map (|>> (_.then (<choice> true idx)) #.Some)))]) + ([/////synthesis.simple_left_side ..left_choice] + [/////synthesis.simple_right_side ..right_choice]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (#.Some (push_cursor! (_.at (_.i32 +0) ..peek_cursor)))) + + ## Extra optimization + (^ (/////synthesis.path/seq + (/////synthesis.member/left 0) + (/////synthesis.!bind_top register thenP))) + (do ///////phase.monad + [then! (recur thenP)] + (wrap (#.Some ($_ _.then + (_.define (..register register) (_.at (_.i32 +0) ..peek_cursor)) + then!)))) + + ## Extra optimization + (^template [<pm> <getter>] + [(^ (/////synthesis.path/seq + (<pm> lefts) + (/////synthesis.!bind_top register thenP))) + (do ///////phase.monad + [then! (recur thenP)] + (wrap (#.Some ($_ _.then + (_.define (..register register) (<getter> (_.i32 (.int lefts)) ..peek_cursor)) + then!))))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^ (/////synthesis.!bind_top register thenP)) + (do ///////phase.monad + [then! (recur thenP)] + (wrap (#.Some ($_ _.then + (_.define (..register register) ..peek_and_pop_cursor) + then!)))) + + (^ (/////synthesis.!multi_pop nextP)) + (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)] + (do ///////phase.monad + [next! (recur nextP')] + (wrap (#.Some ($_ _.then + (multi_pop_cursor! (n.+ 2 extra_pops)) + next!))))) + + _ + (///////phase\wrap #.None))) + +(def: (pattern_matching' statement expression archive) + (-> Phase! Phase Archive + (-> Path (Operation Statement))) + (function (recur pathP) + (do ///////phase.monad + [outcome (optimized_pattern_matching recur pathP)] + (.case outcome + (#.Some outcome) + (wrap outcome) + + #.None + (.case pathP + (#/////synthesis.Then bodyS) + (statement expression archive bodyS) + + #/////synthesis.Pop + (///////phase\wrap pop_cursor!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.define (..register register) ..peek_cursor)) + + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail_pm!))] + (wrap (.if when + (_.if ..peek_cursor + then! + else!) + (_.if ..peek_cursor + else! + then!)))) + + (#/////synthesis.I64_Fork cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (do ! + [then! (recur then)] + (wrap [(//runtime.i64//= (//primitive.i64 (.int match)) + ..peek_cursor) + then!]))) + (#.Cons cons))] + (wrap (_.cond clauses ..fail_pm!))) + + (^template [<tag> <format>] + [(<tag> cons) + (do {! ///////phase.monad} + [cases (monad.map ! (function (_ [match then]) + (\ ! map (|>> [(list (<format> match))]) (recur then))) + (#.Cons cons))] + (wrap (_.switch ..peek_cursor + cases + (#.Some ..fail_pm!))))]) + ([#/////synthesis.F64_Fork //primitive.f64] + [#/////synthesis.Text_Fork //primitive.text]) + + (^template [<complex> <choice>] + [(^ (<complex> idx)) + (///////phase\wrap (<choice> false idx))]) + ([/////synthesis.side/left ..left_choice] + [/////synthesis.side/right ..right_choice]) + + (^template [<pm> <getter>] + [(^ (<pm> lefts)) + (///////phase\wrap (push_cursor! (<getter> (_.i32 (.int lefts)) ..peek_cursor)))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^template [<tag> <combinator>] + [(^ (<tag> leftP rightP)) + (do ///////phase.monad + [left! (recur leftP) + right! (recur rightP)] + (wrap (<combinator> left! right!)))]) + ([/////synthesis.path/seq _.then] + [/////synthesis.path/alt ..alternation])))))) + +(def: (pattern_matching statement expression archive pathP) + (-> Phase! Phase Archive Path (Operation Statement)) + (do ///////phase.monad + [pattern_matching! (pattern_matching' statement expression archive pathP)] + (wrap ($_ _.then + (_.do_while (_.boolean false) + pattern_matching!) + (_.throw (_.string ////synthesis/case.pattern_matching_error)))))) + +(def: #export (case! statement expression archive [valueS pathP]) + (Generator! [Synthesis Path]) + (do ///////phase.monad + [stack_init (expression archive valueS) + pattern_matching! (pattern_matching statement expression archive pathP)] + (wrap ($_ _.then + (_.declare @temp) + (_.define @cursor (_.array (list stack_init))) + (_.define @savepoint (_.array (list))) + pattern_matching!)))) + +(def: #export (case statement expression archive [valueS pathP]) + (-> Phase! (Generator [Synthesis Path])) + (do ///////phase.monad + [pattern_matching! (..case! statement expression archive [valueS pathP])] + (wrap (_.apply/* (_.closure (list) pattern_matching!) (list))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/function.lux new file mode 100644 index 000000000..df13919b0 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/function.lux @@ -0,0 +1,123 @@ +(.module: + [library + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [target + ["_" js (#+ Expression Computation Var Statement)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Phase! Generator)] + ["#." reference] + ["#." case] + ["/#" // #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant Tuple Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["#." generation (#+ Context)] + ["//#" /// #_ + [arity (#+ Arity)] + ["#." phase ("#\." monad)] + [reference + [variable (#+ Register Variable)]]]]]]) + +(def: #export (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do {! ///////phase.monad} + [functionO (expression archive functionS) + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply/* functionO argsO+)))) + +(def: capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: (with_closure @self inits body!) + (-> Var (List Expression) Statement [Statement Expression]) + (case inits + #.Nil + [(_.function! @self (list) body!) + @self] + + _ + [(_.function! @self + (|> (list.enumeration inits) + (list\map (|>> product.left ..capture))) + (_.return (_.function @self (list) body!))) + (_.apply/* @self inits)])) + +(def: @curried + (_.var "curried")) + +(def: input + (|>> inc //case.register)) + +(def: @@arguments + (_.var "arguments")) + +(def: (@scope function_name) + (-> Context Text) + (format (///reference.artifact function_name) "_scope")) + +(def: #export (function statement expression archive [environment arity bodyS]) + (-> Phase! (Generator (Abstraction Synthesis))) + (do {! ///////phase.monad} + [[function_name body!] (/////generation.with_new_context archive + (do ! + [scope (\ ! map ..@scope + (/////generation.context archive))] + (/////generation.with_anchor [1 scope] + (statement expression archive bodyS)))) + #let [arityO (|> arity .int _.i32) + @num_args (_.var "num_args") + @scope (..@scope function_name) + @self (_.var (///reference.artifact function_name)) + apply_poly (.function (_ args func) + (|> func (_.do "apply" (list _.null args)))) + initialize_self! (_.define (//case.register 0) @self) + initialize! (list\fold (.function (_ post pre!) + ($_ _.then + pre! + (_.define (..input post) (_.at (_.i32 (.int post)) @@arguments)))) + initialize_self! + (list.indices arity))] + environment (monad.map ! (expression archive) environment) + #let [[definition instantiation] (with_closure @self environment + ($_ _.then + (_.define @num_args (_.the "length" @@arguments)) + (_.cond (list [(|> @num_args (_.= arityO)) + ($_ _.then + initialize! + (_.with_label (_.label @scope) + (_.do_while (_.boolean true) + body!)))] + [(|> @num_args (_.> arityO)) + (let [arity_inputs (|> (_.array (list)) + (_.the "slice") + (_.do "call" (list @@arguments (_.i32 +0) arityO))) + extra_inputs (|> (_.array (list)) + (_.the "slice") + (_.do "call" (list @@arguments arityO)))] + (_.return (|> @self + (apply_poly arity_inputs) + (apply_poly extra_inputs))))]) + ## (|> @num_args (_.< arityO)) + (let [all_inputs (|> (_.array (list)) + (_.the "slice") + (_.do "call" (list @@arguments)))] + ($_ _.then + (_.define @curried all_inputs) + (_.return (_.closure (list) + (let [@missing all_inputs] + (_.return (apply_poly (_.do "concat" (list @missing) @curried) + @self)))))))) + ))] + _ (/////generation.execute! definition) + _ (/////generation.save! (product.right function_name) definition)] + (wrap instantiation))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/loop.lux new file mode 100644 index 000000000..720257105 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/loop.lux @@ -0,0 +1,91 @@ +(.module: + [library + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [math + [number + ["n" nat]]] + [target + ["_" js (#+ Computation Var Expression Statement)]]]] + ["." // #_ + [runtime (#+ Operation Phase Phase! Generator Generator!)] + ["#." case] + ["///#" //// #_ + [synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [reference + [variable (#+ Register)]]]]]) + +(def: @scope + (-> Nat Text) + (|>> %.nat (format "scope"))) + +(def: (setup initial? offset bindings body) + (-> Bit Register (List Expression) Statement Statement) + (|> bindings + list.enumeration + (list\map (function (_ [register value]) + (let [variable (//case.register (n.+ offset register))] + (if initial? + (_.define variable value) + (_.set variable value))))) + list.reverse + (list\fold _.then body))) + +(def: #export (scope! statement expression archive [start initsS+ bodyS]) + (Generator! (Scope Synthesis)) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (statement expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [@scope (\ ! map ..@scope /////generation.next) + initsO+ (monad.map ! (expression archive) initsS+) + body! (/////generation.with_anchor [start @scope] + (statement expression archive bodyS))] + (wrap (..setup true start initsO+ + (_.with_label (_.label @scope) + (_.do_while (_.boolean true) + body!))))))) + +(def: #export (scope statement expression archive [start initsS+ bodyS]) + (-> Phase! (Generator (Scope Synthesis))) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [loop! (scope! statement expression archive [start initsS+ bodyS])] + (wrap (_.apply/* (_.closure (list) loop!) (list)))))) + +(def: @temp + (_.var "lux_recur_values")) + +(def: #export (recur! statement expression archive argsS+) + (Generator! (List Synthesis)) + (do {! ///////phase.monad} + [[offset @scope] /////generation.anchor + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap ($_ _.then + (_.define @temp (_.array argsO+)) + (..setup false offset + (|> argsO+ + list.enumeration + (list\map (function (_ [idx _]) + (_.at (_.i32 (.int idx)) @temp)))) + (_.continue_at (_.label @scope))))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux new file mode 100644 index 000000000..ede743c5d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux @@ -0,0 +1,21 @@ +(.module: + [library + [lux (#- i64) + [target + ["_" js (#+ Computation)]]]] + ["." // #_ + ["#." runtime]]) + +(def: #export bit + _.boolean) + +(def: #export (i64 value) + (-> (I64 Any) Computation) + (//runtime.i64 (|> value //runtime.high .int _.i32) + (|> value //runtime.low .int _.i32))) + +(def: #export f64 + _.number) + +(def: #export text + _.string) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/reference.lux new file mode 100644 index 000000000..b21262192 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" js (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System Expression) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux new file mode 100644 index 000000000..2f6370418 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux @@ -0,0 +1,785 @@ +(.module: + [library + [lux (#- i64) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<.>" code]]] + [data + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." list ("#\." functor)] + ["." row]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["." i64]]] + [target + ["_" js (#+ Expression Var Computation Statement)]] + [tool + [compiler + [language + [lux + ["$" version]]]]]]] + ["." /// #_ + ["#." reference] + ["//#" /// #_ + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// + ["#." phase] + [reference + [variable (#+ Register)]] + [meta + [archive (#+ Output Archive) + ["." artifact (#+ Registry)]]]]]]) + +(template [<name> <base>] + [(type: #export <name> + (<base> [Register Text] Expression Statement))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type: #export (Generator i) + (-> Phase Archive i (Operation Expression))) + +(type: #export Phase! + (-> Phase Archive Synthesis (Operation Statement))) + +(type: #export (Generator! i) + (-> Phase! Phase Archive i (Operation Statement))) + +(def: #export high + (-> (I64 Any) (I64 Any)) + (i64.right_shift 32)) + +(def: #export low + (-> (I64 Any) (I64 Any)) + (let [mask (dec (i64.left_shift 32 1))] + (|>> (i64.and mask)))) + +(def: #export unit + Computation + (_.string /////synthesis.unit)) + +(def: #export (flag value) + (-> Bit Computation) + (if value + (_.string "") + _.null)) + +(def: (feature name definition) + (-> Var (-> Var Expression) Statement) + (_.define name (definition name))) + +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} + body) + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} + code) + (macro.with_gensyms [g!_ runtime] + (let [runtime_name (` (_.var (~ (code.text (%.code runtime)))))] + (case declaration + (#.Left name) + (let [g!name (code.local_identifier name)] + (wrap (list (` (def: #export (~ g!name) + Var + (~ runtime_name))) + + (` (def: (~ (code.local_identifier (format "@" name))) + Statement + (..feature (~ runtime_name) + (function ((~ g!_) (~ g!name)) + (~ code)))))))) + + (#.Right [name inputs]) + (let [g!name (code.local_identifier name) + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` _.Expression)) inputs)] + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) + (-> (~+ inputs_typesC) Computation) + (_.apply/* (~ runtime_name) (list (~+ inputsC))))) + + (` (def: (~ (code.local_identifier (format "@" name))) + Statement + (..feature (~ runtime_name) + (function ((~ g!_) (~ g!_)) + (..with_vars [(~+ inputsC)] + (_.function (~ g!_) (list (~+ inputsC)) + (~ code)))))))))))))) + +(def: length + (-> Expression Computation) + (_.the "length")) + +(def: last_index + (-> Expression Computation) + (|>> ..length (_.- (_.i32 +1)))) + +(def: (last_element tuple) + (_.at (..last_index tuple) + tuple)) + +(with_expansions [<recur> (as_is ($_ _.then + (_.set lefts (_.- last_index_right lefts)) + (_.set tuple (_.at last_index_right tuple))))] + (runtime: (tuple//left lefts tuple) + (with_vars [last_index_right] + (<| (_.while (_.boolean true)) + ($_ _.then + (_.define last_index_right (..last_index tuple)) + (_.if (_.> lefts last_index_right) + ## No need for recursion + (_.return (_.at lefts tuple)) + ## Needs recursion + <recur>))))) + + (runtime: (tuple//right lefts tuple) + (with_vars [last_index_right right_index] + (<| (_.while (_.boolean true)) + ($_ _.then + (_.define last_index_right (..last_index tuple)) + (_.define right_index (_.+ (_.i32 +1) lefts)) + (_.cond (list [(_.= last_index_right right_index) + (_.return (_.at right_index tuple))] + [(_.> last_index_right right_index) + ## Needs recursion. + <recur>]) + (_.return (_.do "slice" (list right_index) tuple))) + ))))) + +(def: #export variant_tag_field "_lux_tag") +(def: #export variant_flag_field "_lux_flag") +(def: #export variant_value_field "_lux_value") + +(runtime: variant//new + (let [@this (_.var "this")] + (with_vars [tag is_last value] + (_.closure (list tag is_last value) + ($_ _.then + (_.set (_.the ..variant_tag_field @this) tag) + (_.set (_.the ..variant_flag_field @this) is_last) + (_.set (_.the ..variant_value_field @this) value) + ))))) + +(def: #export (variant tag last? value) + (-> Expression Expression Expression Computation) + (_.new ..variant//new (list tag last? value))) + +(runtime: (sum//get sum wants_last wanted_tag) + (let [no_match! (_.return _.null) + sum_tag (|> sum (_.the ..variant_tag_field)) + sum_flag (|> sum (_.the ..variant_flag_field)) + sum_value (|> sum (_.the ..variant_value_field)) + is_last? (_.= ..unit sum_flag) + extact_match! (_.return sum_value) + test_recursion! (_.if is_last? + ## Must recurse. + ($_ _.then + (_.set wanted_tag (_.- sum_tag wanted_tag)) + (_.set sum sum_value)) + no_match!) + extrac_sub_variant! (_.return (..variant (_.- wanted_tag sum_tag) sum_flag sum_value))] + (<| (_.while (_.boolean true)) + (_.cond (list [(_.= wanted_tag sum_tag) + (_.if (_.= wants_last sum_flag) + extact_match! + test_recursion!)] + [(_.< wanted_tag sum_tag) + test_recursion!] + [(_.= ..unit wants_last) + extrac_sub_variant!]) + no_match!)))) + +(def: none + Computation + (..variant (_.i32 +0) (flag #0) unit)) + +(def: some + (-> Expression Computation) + (..variant (_.i32 +1) (flag #1))) + +(def: left + (-> Expression Computation) + (..variant (_.i32 +0) (flag #0))) + +(def: right + (-> Expression Computation) + (..variant (_.i32 +1) (flag #1))) + +(def: runtime//structure + Statement + ($_ _.then + @tuple//left + @tuple//right + @variant//new + @sum//get + )) + +(runtime: (lux//try op) + (with_vars [ex] + (_.try (_.return (..right (_.apply/1 op ..unit))) + [ex (_.return (..left (|> ex (_.do "toString" (list)))))]))) + +(runtime: (lux//program_args inputs) + (with_vars [output idx] + ($_ _.then + (_.define output ..none) + (_.for idx + (..last_index inputs) + (_.>= (_.i32 +0) idx) + (_.-- idx) + (_.set output (..some (_.array (list (_.at idx inputs) + output))))) + (_.return output)))) + +(def: runtime//lux + Statement + ($_ _.then + @lux//try + @lux//program_args + )) + +(def: #export i64_low_field Text "_lux_low") +(def: #export i64_high_field Text "_lux_high") + +(runtime: i64//new + (let [@this (_.var "this")] + (with_vars [high low] + (_.closure (list high low) + ($_ _.then + (_.set (_.the ..i64_high_field @this) high) + (_.set (_.the ..i64_low_field @this) low) + ))))) + +(def: #export (i64 high low) + (-> Expression Expression Computation) + (_.new ..i64//new (list high low))) + +(runtime: i64//2^16 + (_.left_shift (_.i32 +16) (_.i32 +1))) + +(runtime: i64//2^32 + (_.* i64//2^16 i64//2^16)) + +(runtime: i64//2^64 + (_.* i64//2^32 i64//2^32)) + +(runtime: i64//2^63 + (|> i64//2^64 (_./ (_.i32 +2)))) + +(runtime: (i64//unsigned_low i64) + (_.return (_.? (|> i64 (_.the ..i64_low_field) (_.>= (_.i32 +0))) + (|> i64 (_.the ..i64_low_field)) + (|> i64 (_.the ..i64_low_field) (_.+ i64//2^32))))) + +(runtime: (i64//to_number i64) + (_.return (|> i64 + (_.the ..i64_high_field) + (_.* i64//2^32) + (_.+ (i64//unsigned_low i64))))) + +(runtime: i64//zero + (..i64 (_.i32 +0) (_.i32 +0))) + +(runtime: i64//min + (..i64 (_.i32 (.int (hex "80,00,00,00"))) + (_.i32 +0))) + +(runtime: i64//max + (..i64 (_.i32 (.int (hex "7F,FF,FF,FF"))) + (_.i32 (.int (hex "FF,FF,FF,FF"))))) + +(runtime: i64//one + (..i64 (_.i32 +0) (_.i32 +1))) + +(runtime: (i64//= reference sample) + (_.return (_.and (_.= (_.the ..i64_high_field reference) + (_.the ..i64_high_field sample)) + (_.= (_.the ..i64_low_field reference) + (_.the ..i64_low_field sample))))) + +(runtime: (i64//+ parameter subject) + (let [up_16 (_.left_shift (_.i32 +16)) + high_16 (_.logic_right_shift (_.i32 +16)) + low_16 (_.bit_and (_.i32 (.int (hex "FFFF")))) + hh (|>> (_.the ..i64_high_field) high_16) + hl (|>> (_.the ..i64_high_field) low_16) + lh (|>> (_.the ..i64_low_field) high_16) + ll (|>> (_.the ..i64_low_field) low_16)] + (with_vars [l48 l32 l16 l00 + r48 r32 r16 r00 + x48 x32 x16 x00] + ($_ _.then + (_.define l48 (hh subject)) + (_.define l32 (hl subject)) + (_.define l16 (lh subject)) + (_.define l00 (ll subject)) + + (_.define r48 (hh parameter)) + (_.define r32 (hl parameter)) + (_.define r16 (lh parameter)) + (_.define r00 (ll parameter)) + + (_.define x00 (_.+ l00 r00)) + + (_.define x16 (|> (high_16 x00) + (_.+ l16) + (_.+ r16))) + (_.set x00 (low_16 x00)) + + (_.define x32 (|> (high_16 x16) + (_.+ l32) + (_.+ r32))) + (_.set x16 (low_16 x16)) + + (_.define x48 (|> (high_16 x32) + (_.+ l48) + (_.+ r48) + low_16)) + (_.set x32 (low_16 x32)) + + (_.return (..i64 (_.bit_or (up_16 x48) x32) + (_.bit_or (up_16 x16) x00))) + )))) + +(template [<name> <op>] + [(runtime: (<name> subject parameter) + (_.return (..i64 (<op> (_.the ..i64_high_field subject) + (_.the ..i64_high_field parameter)) + (<op> (_.the ..i64_low_field subject) + (_.the ..i64_low_field parameter)))))] + + [i64//xor _.bit_xor] + [i64//or _.bit_or] + [i64//and _.bit_and] + ) + +(runtime: (i64//not value) + (_.return (..i64 (_.bit_not (_.the ..i64_high_field value)) + (_.bit_not (_.the ..i64_low_field value))))) + +(runtime: (i64//negate value) + (_.return (_.? (i64//= i64//min value) + i64//min + (i64//+ i64//one (i64//not value))))) + +(runtime: i64//-one + (i64//negate i64//one)) + +(runtime: (i64//from_number value) + (_.return (<| (_.? (_.not_a_number? value) + i64//zero) + (_.? (_.<= (_.negate i64//2^63) value) + i64//min) + (_.? (|> value (_.+ (_.i32 +1)) (_.>= i64//2^63)) + i64//max) + (_.? (|> value (_.< (_.i32 +0))) + (|> value _.negate i64//from_number i64//negate)) + (..i64 (|> value (_./ i64//2^32) _.to_i32) + (|> value (_.% i64//2^32) _.to_i32))))) + +(def: (cap_shift! shift) + (-> Var Statement) + (_.set shift (|> shift (_.bit_and (_.i32 +63))))) + +(def: (no_shift! shift input) + (-> Var Var (-> Expression Expression)) + (_.? (|> shift (_.= (_.i32 +0))) + input)) + +(def: small_shift? + (-> Var Expression) + (|>> (_.< (_.i32 +32)))) + +(runtime: (i64//left_shift input shift) + ($_ _.then + (..cap_shift! shift) + (_.return (<| (..no_shift! shift input) + (_.? (..small_shift? shift) + (let [high (_.bit_or (|> input (_.the ..i64_high_field) (_.left_shift shift)) + (|> input (_.the ..i64_low_field) (_.logic_right_shift (_.- shift (_.i32 +32))))) + low (|> input (_.the ..i64_low_field) (_.left_shift shift))] + (..i64 high low))) + (let [high (|> input (_.the ..i64_low_field) (_.left_shift (_.- (_.i32 +32) shift)))] + (..i64 high (_.i32 +0))))) + )) + +(runtime: (i64//arithmetic_right_shift input shift) + ($_ _.then + (..cap_shift! shift) + (_.return (<| (..no_shift! shift input) + (_.? (..small_shift? shift) + (let [high (|> input (_.the ..i64_high_field) (_.arithmetic_right_shift shift)) + low (|> input (_.the ..i64_low_field) (_.logic_right_shift shift) + (_.bit_or (|> input (_.the ..i64_high_field) (_.left_shift (_.- shift (_.i32 +32))))))] + (..i64 high low))) + (let [high (_.? (|> input (_.the ..i64_high_field) (_.>= (_.i32 +0))) + (_.i32 +0) + (_.i32 -1)) + low (|> input (_.the ..i64_high_field) (_.arithmetic_right_shift (_.- (_.i32 +32) shift)))] + (..i64 high low)))))) + +(runtime: (i64//right_shift input shift) + ($_ _.then + (..cap_shift! shift) + (_.return (<| (..no_shift! shift input) + (_.? (..small_shift? shift) + (let [high (|> input (_.the ..i64_high_field) (_.logic_right_shift shift)) + low (|> input (_.the ..i64_low_field) (_.logic_right_shift shift) + (_.bit_or (|> input (_.the ..i64_high_field) (_.left_shift (_.- shift (_.i32 +32))))))] + (..i64 high low))) + (_.? (|> shift (_.= (_.i32 +32))) + (..i64 (_.i32 +0) (|> input (_.the ..i64_high_field)))) + (..i64 (_.i32 +0) + (|> input (_.the ..i64_high_field) (_.logic_right_shift (_.- (_.i32 +32) shift)))))))) + +(def: runtime//bit + Statement + ($_ _.then + @i64//and + @i64//or + @i64//xor + @i64//not + @i64//left_shift + @i64//arithmetic_right_shift + @i64//right_shift + )) + +(runtime: (i64//- parameter subject) + (_.return (i64//+ (i64//negate parameter) subject))) + +(runtime: (i64//* parameter subject) + (let [up_16 (_.left_shift (_.i32 +16)) + high_16 (_.logic_right_shift (_.i32 +16)) + low_16 (_.bit_and (_.i32 (.int (hex "FFFF")))) + hh (|>> (_.the ..i64_high_field) high_16) + hl (|>> (_.the ..i64_high_field) low_16) + lh (|>> (_.the ..i64_low_field) high_16) + ll (|>> (_.the ..i64_low_field) low_16)] + (with_vars [l48 l32 l16 l00 + r48 r32 r16 r00 + x48 x32 x16 x00] + ($_ _.then + (_.define l48 (hh subject)) + (_.define l32 (hl subject)) + (_.define l16 (lh subject)) + (_.define l00 (ll subject)) + + (_.define r48 (hh parameter)) + (_.define r32 (hl parameter)) + (_.define r16 (lh parameter)) + (_.define r00 (ll parameter)) + + (_.define x00 (_.* l00 r00)) + (_.define x16 (high_16 x00)) + (_.set x00 (low_16 x00)) + + (_.set x16 (|> x16 (_.+ (_.* l16 r00)))) + (_.define x32 (high_16 x16)) (_.set x16 (low_16 x16)) + (_.set x16 (|> x16 (_.+ (_.* l00 r16)))) + (_.set x32 (|> x32 (_.+ (high_16 x16)))) (_.set x16 (low_16 x16)) + + (_.set x32 (|> x32 (_.+ (_.* l32 r00)))) + (_.define x48 (high_16 x32)) (_.set x32 (low_16 x32)) + (_.set x32 (|> x32 (_.+ (_.* l16 r16)))) + (_.set x48 (|> x48 (_.+ (high_16 x32)))) (_.set x32 (low_16 x32)) + (_.set x32 (|> x32 (_.+ (_.* l00 r32)))) + (_.set x48 (|> x48 (_.+ (high_16 x32)))) (_.set x32 (low_16 x32)) + + (_.set x48 (|> x48 + (_.+ (_.* l48 r00)) + (_.+ (_.* l32 r16)) + (_.+ (_.* l16 r32)) + (_.+ (_.* l00 r48)) + low_16)) + + (_.return (..i64 (_.bit_or (up_16 x48) x32) + (_.bit_or (up_16 x16) x00))) + )))) + +(runtime: (i64//< parameter subject) + (let [negative? (|>> (_.the ..i64_high_field) (_.< (_.i32 +0)))] + (with_vars [-subject? -parameter?] + ($_ _.then + (_.define -subject? (negative? subject)) + (_.define -parameter? (negative? parameter)) + (_.return (<| (_.? (_.and -subject? (_.not -parameter?)) + (_.boolean true)) + (_.? (_.and (_.not -subject?) -parameter?) + (_.boolean false)) + (negative? (i64//- parameter subject)))) + )))) + +(def: (i64//<= param subject) + (-> Expression Expression Expression) + (|> (i64//< param subject) + (_.or (i64//= param subject)))) + +(runtime: (i64/// parameter subject) + (let [negative? (function (_ value) + (i64//< i64//zero value)) + valid_division_check [(i64//= i64//zero parameter) + (_.throw (_.string "Cannot divide by zero!"))] + short_circuit_check [(i64//= i64//zero subject) + (_.return i64//zero)]] + (_.cond (list valid_division_check + short_circuit_check + + [(i64//= i64//min subject) + (_.cond (list [(_.or (i64//= i64//one parameter) + (i64//= i64//-one parameter)) + (_.return i64//min)] + [(i64//= i64//min parameter) + (_.return i64//one)]) + (with_vars [approximation] + (let [subject/2 (..i64//arithmetic_right_shift subject (_.i32 +1))] + ($_ _.then + (_.define approximation (i64//left_shift (i64/// parameter + subject/2) + (_.i32 +1))) + (_.if (i64//= i64//zero approximation) + (_.return (_.? (negative? parameter) + i64//one + i64//-one)) + (let [remainder (i64//- (i64//* approximation + parameter) + subject)] + (_.return (i64//+ (i64/// parameter + remainder) + approximation))))))))] + [(i64//= i64//min parameter) + (_.return i64//zero)] + + [(negative? subject) + (_.return (_.? (negative? parameter) + (i64/// (i64//negate parameter) + (i64//negate subject)) + (i64//negate (i64/// parameter + (i64//negate subject)))))] + + [(negative? parameter) + (_.return (i64//negate (i64/// (i64//negate parameter) subject)))]) + (with_vars [result remainder] + ($_ _.then + (_.define result i64//zero) + (_.define remainder subject) + (_.while (i64//<= remainder parameter) + (with_vars [approximate approximate_result approximate_remainder log2 delta] + (let [approximate_result' (i64//from_number approximate) + approx_remainder (i64//* parameter approximate_result)] + ($_ _.then + (_.define approximate (|> (i64//to_number remainder) + (_./ (i64//to_number parameter)) + (_.apply/1 (_.var "Math.floor")) + (_.apply/2 (_.var "Math.max") (_.i32 +1)))) + (_.define log2 (|> approximate + (_.apply/1 (_.var "Math.log")) + (_./ (_.var "Math.LN2")) + (_.apply/1 (_.var "Math.ceil")))) + (_.define delta (_.? (_.<= (_.i32 +48) log2) + (_.i32 +1) + (_.apply/2 (_.var "Math.pow") + (_.i32 +2) + (_.- (_.i32 +48) + log2)))) + (_.define approximate_result approximate_result') + (_.define approximate_remainder approx_remainder) + (_.while (_.or (negative? approximate_remainder) + (i64//< approximate_remainder + remainder)) + ($_ _.then + (_.set approximate (_.- delta approximate)) + (_.set approximate_result approximate_result') + (_.set approximate_remainder approx_remainder))) + (_.set result (i64//+ (_.? (i64//= i64//zero approximate_result) + i64//one + approximate_result) + result)) + (_.set remainder (i64//- approximate_remainder remainder)))))) + (_.return result))) + ))) + +(runtime: (i64//% parameter subject) + (let [flat (|> subject + (i64/// parameter) + (i64//* parameter))] + (_.return (i64//- flat subject)))) + +(def: runtime//i64 + Statement + ($_ _.then + @i64//2^16 + @i64//2^32 + @i64//2^64 + @i64//2^63 + @i64//unsigned_low + @i64//new + @i64//zero + @i64//min + @i64//max + @i64//one + @i64//= + @i64//+ + @i64//negate + @i64//to_number + @i64//from_number + @i64//- + @i64//* + @i64//< + @i64/// + @i64//% + runtime//bit + )) + +(runtime: (text//index start part text) + (with_vars [idx] + ($_ _.then + (_.define idx (|> text (_.do "indexOf" (list part (i64//to_number start))))) + (_.return (_.? (_.= (_.i32 -1) idx) + ..none + (..some (i64//from_number idx))))))) + +(runtime: (text//clip offset length text) + (_.return (|> text (_.do "substring" (list (_.the ..i64_low_field offset) + (_.+ (_.the ..i64_low_field offset) + (_.the ..i64_low_field length))))))) + +(runtime: (text//char idx text) + (with_vars [result] + ($_ _.then + (_.define result (|> text (_.do "charCodeAt" (list (_.the ..i64_low_field idx))))) + (_.if (_.not_a_number? result) + (_.throw (_.string "[Lux Error] Cannot get char from text.")) + (_.return (i64//from_number result)))))) + +(def: runtime//text + Statement + ($_ _.then + @text//index + @text//clip + @text//char + )) + +(runtime: (io//log message) + (let [console (_.var "console") + print (_.var "print") + end! (_.return ..unit)] + (_.cond (list [(|> console _.type_of (_.= (_.string "undefined")) _.not + (_.and (_.the "log" console))) + ($_ _.then + (_.statement (|> console (_.do "log" (list message)))) + end!)] + [(|> print _.type_of (_.= (_.string "undefined")) _.not) + ($_ _.then + (_.statement (_.apply/1 print (_.? (_.= (_.string "string") + (_.type_of message)) + message + (_.apply/1 (_.var "JSON.stringify") message)))) + end!)]) + end!))) + +(runtime: (io//error message) + (_.throw message)) + +(def: runtime//io + Statement + ($_ _.then + @io//log + @io//error + )) + +(runtime: (js//get object field) + (with_vars [temp] + ($_ _.then + (_.define temp (_.at field object)) + (_.return (_.? (_.= _.undefined temp) + ..none + (..some temp)))))) + +(runtime: (js//set object field input) + ($_ _.then + (_.set (_.at field object) input) + (_.return object))) + +(runtime: (js//delete object field) + ($_ _.then + (_.delete (_.at field object)) + (_.return object))) + +(def: runtime//js + Statement + ($_ _.then + @js//get + @js//set + @js//delete + )) + +(runtime: (array//write idx value array) + ($_ _.then + (_.set (_.at (_.the ..i64_low_field idx) array) value) + (_.return array))) + +(runtime: (array//delete idx array) + ($_ _.then + (_.delete (_.at (_.the ..i64_low_field idx) array)) + (_.return array))) + +(def: runtime//array + Statement + ($_ _.then + @array//write + @array//delete + )) + +(def: runtime + Statement + ($_ _.then + runtime//structure + runtime//i64 + runtime//text + runtime//io + runtime//js + runtime//array + runtime//lux + )) + +(def: module_id + 0) + +(def: #export generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! ..module_id ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row [..module_id + (|> ..runtime + _.code + (\ utf8.codec encode))])]))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/structure.lux new file mode 100644 index 000000000..8c68d5b23 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/structure.lux @@ -0,0 +1,38 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [target + ["_" js (#+ Expression)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." primitive] + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + ["//#" /// + ["#." phase ("#\." monad)]]]]) + +(def: #export (tuple generate archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + #.Nil + (///////phase\wrap //runtime.unit) + + (#.Cons singletonS #.Nil) + (generate archive singletonS) + + _ + (do {! ///////phase.monad} + [elemsT+ (monad.map ! (generate archive) elemsS+)] + (wrap (_.array elemsT+))))) + +(def: #export (variant generate archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (inc lefts) + lefts)] + (///////phase\map (//runtime.variant (_.i32 (.int tag)) + (//runtime.flag right?)) + (generate archive valueS)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm.lux new file mode 100644 index 000000000..e8357027d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm.lux @@ -0,0 +1,73 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]]]] + ["." / #_ + [runtime (#+ Phase)] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." function] + ["#." case] + ["#." loop] + ["//#" /// #_ + ["#." extension] + [// + ["." synthesis] + [/// + ["." reference] + ["#" phase ("#\." monad)]]]]]) + +(def: #export (generate archive synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + [(^ (<tag> value)) + (///\wrap (<generator> value))]) + ([synthesis.bit /primitive.bit] + [synthesis.i64 /primitive.i64] + [synthesis.f64 /primitive.f64] + [synthesis.text /primitive.text]) + + (^ (synthesis.variant variantS)) + (/structure.variant generate archive variantS) + + (^ (synthesis.tuple members)) + (/structure.tuple generate archive members) + + (#synthesis.Reference reference) + (case reference + (#reference.Variable variable) + (/reference.variable archive variable) + + (#reference.Constant constant) + (/reference.constant archive constant)) + + (^ (synthesis.branch/case [valueS pathS])) + (/case.case generate archive [valueS pathS]) + + (^ (synthesis.branch/let [inputS register bodyS])) + (/case.let generate archive [inputS register bodyS]) + + (^ (synthesis.branch/if [conditionS thenS elseS])) + (/case.if generate archive [conditionS thenS elseS]) + + (^ (synthesis.branch/get [path recordS])) + (/case.get generate archive [path recordS]) + + (^ (synthesis.loop/scope scope)) + (/loop.scope generate archive scope) + + (^ (synthesis.loop/recur updates)) + (/loop.recur generate archive updates) + + (^ (synthesis.function/abstraction abstraction)) + (/function.abstraction generate archive abstraction) + + (^ (synthesis.function/apply application)) + (/function.apply generate archive application) + + (#synthesis.Extension extension) + (///extension.apply archive generate extension) + )) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux new file mode 100644 index 000000000..7d2416d67 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux @@ -0,0 +1,266 @@ +(.module: + [library + [lux (#- Type if let case int) + [abstract + ["." monad (#+ do)]] + [control + ["." function]] + [data + [number + ["." i32] + ["n" nat]] + [collection + ["." list ("#\." fold)]]] + [target + [jvm + ["_" bytecode (#+ Label Bytecode) ("#\." monad)] + ["." type (#+ Type) + [category (#+ Method)]]]]]] + ["." // #_ + ["#." type] + ["#." runtime (#+ Operation Phase Generator)] + ["#." value] + ["#." structure] + [//// + ["." synthesis (#+ Path Synthesis)] + ["." generation] + [/// + ["." phase ("operation\." monad)] + [reference + [variable (#+ Register)]]]]]) + +(def: equals-name + "equals") + +(def: equals-type + (type.method [(list //type.value) type.boolean (list)])) + +(def: (pop-alt stack-depth) + (-> Nat (Bytecode Any)) + (.case stack-depth + 0 (_\wrap []) + 1 _.pop + 2 _.pop2 + _ ## (n.> 2) + ($_ _.compose + _.pop2 + (pop-alt (n.- 2 stack-depth))))) + +(def: int + (-> (I64 Any) (Bytecode Any)) + (|>> .i64 i32.i32 _.int)) + +(def: long + (-> (I64 Any) (Bytecode Any)) + (|>> .int _.long)) + +(def: double + (-> Frac (Bytecode Any)) + (|>> _.double)) + +(def: peek + (Bytecode Any) + ($_ _.compose + _.dup + (//runtime.get //runtime.stack-head))) + +(def: pop + (Bytecode Any) + ($_ _.compose + (//runtime.get //runtime.stack-tail) + (_.checkcast //type.stack))) + +(def: (left-projection lefts) + (-> Nat (Bytecode Any)) + ($_ _.compose + (_.checkcast //type.tuple) + (..int lefts) + (.case lefts + 0 + _.aaload + + lefts + //runtime.left-projection))) + +(def: (right-projection lefts) + (-> Nat (Bytecode Any)) + ($_ _.compose + (_.checkcast //type.tuple) + (..int lefts) + //runtime.right-projection)) + +(def: (path' stack-depth @else @end phase archive path) + (-> Nat Label Label (Generator Path)) + (.case path + #synthesis.Pop + (operation\wrap ..pop) + + (#synthesis.Bind register) + (operation\wrap ($_ _.compose + ..peek + (_.astore register))) + + (#synthesis.Then bodyS) + (do phase.monad + [bodyG (phase archive bodyS)] + (wrap ($_ _.compose + (..pop-alt stack-depth) + bodyG + (_.goto @end)))) + + (^template [<pattern> <right?>] + [(^ (<pattern> lefts)) + (operation\wrap + (do _.monad + [@success _.new-label + @fail _.new-label] + ($_ _.compose + ..peek + (_.checkcast //type.variant) + (//structure.tag lefts <right?>) + (//structure.flag <right?>) + //runtime.case + _.dup + (_.ifnull @fail) + (_.goto @success) + (_.set-label @fail) + _.pop + (_.goto @else) + (_.set-label @success) + //runtime.push)))]) + ([synthesis.side/left false] + [synthesis.side/right true]) + + (^template [<pattern> <projection>] + [(^ (<pattern> lefts)) + (operation\wrap ($_ _.compose + ..peek + (<projection> lefts) + //runtime.push))]) + ([synthesis.member/left ..left-projection] + [synthesis.member/right ..right-projection]) + + ## Extra optimization + (^ (synthesis.path/seq + (synthesis.member/left 0) + (synthesis.!bind-top register thenP))) + (do phase.monad + [thenG (path' stack-depth @else @end phase archive thenP)] + (wrap ($_ _.compose + ..peek + (_.checkcast //type.tuple) + _.iconst-0 + _.aaload + (_.astore register) + thenG))) + + ## Extra optimization + (^template [<pm> <projection>] + [(^ (synthesis.path/seq + (<pm> lefts) + (synthesis.!bind-top register thenP))) + (do phase.monad + [then! (path' stack-depth @else @end phase archive thenP)] + (wrap ($_ _.compose + ..peek + (_.checkcast //type.tuple) + (..int lefts) + <projection> + (_.astore register) + then!)))]) + ([synthesis.member/left //runtime.left-projection] + [synthesis.member/right //runtime.right-projection]) + + (#synthesis.Alt leftP rightP) + (do phase.monad + [@alt-else //runtime.forge-label + left! (path' (inc stack-depth) @alt-else @end phase archive leftP) + right! (path' stack-depth @else @end phase archive rightP)] + (wrap ($_ _.compose + _.dup + left! + (_.set-label @alt-else) + _.pop + right!))) + + (#synthesis.Seq leftP rightP) + (do phase.monad + [left! (path' stack-depth @else @end phase archive leftP) + right! (path' stack-depth @else @end phase archive rightP)] + (wrap ($_ _.compose + left! + right!))) + + _ + (undefined) + )) + +(def: (path @end phase archive path) + (-> Label (Generator Path)) + (do phase.monad + [@else //runtime.forge-label + pathG (..path' 1 @else @end phase archive path)] + (wrap ($_ _.compose + pathG + (_.set-label @else) + _.pop + //runtime.pm-failure + _.aconst-null + (_.goto @end))))) + +(def: #export (if phase archive [conditionS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do phase.monad + [conditionG (phase archive conditionS) + thenG (phase archive thenS) + elseG (phase archive elseS)] + (wrap (do _.monad + [@else _.new-label + @end _.new-label] + ($_ _.compose + conditionG + (//value.unwrap type.boolean) + (_.ifeq @else) + thenG + (_.goto @end) + (_.set-label @else) + elseG + (_.set-label @end)))))) + +(def: #export (let phase archive [inputS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do phase.monad + [inputG (phase archive inputS) + bodyG (phase archive bodyS)] + (wrap ($_ _.compose + inputG + (_.astore register) + bodyG)))) + +(def: #export (get phase archive [path recordS]) + (Generator [(List synthesis.Member) Synthesis]) + (do phase.monad + [recordG (phase archive recordS)] + (wrap (list\fold (function (_ step so-far) + (.let [next (.case step + (#.Left lefts) + (..left-projection lefts) + + (#.Right lefts) + (..right-projection lefts))] + (_.compose so-far next))) + recordG + (list.reverse path))))) + +(def: #export (case phase archive [valueS path]) + (Generator [Synthesis Path]) + (do phase.monad + [@end //runtime.forge-label + valueG (phase archive valueS) + pathG (..path @end phase archive path)] + (wrap ($_ _.compose + _.aconst-null + valueG + //runtime.push + pathG + (_.set-label @end))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux new file mode 100644 index 000000000..65c141283 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux @@ -0,0 +1,31 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." io (#+ IO)] + ["." try (#+ Try)]] + [data + [binary (#+ Binary)] + [text + ["%" format (#+ format)]]] + [world + ["." file (#+ File)]]]]) + +(def: extension ".class") + +(def: #export (write-class! name bytecode) + (-> Text Binary (IO Text)) + (let [file-path (format name ..extension)] + (do io.monad + [outcome (do (try.with @) + [file (: (IO (Try (File IO))) + (file.get-file io.monad file.default file-path))] + (\ file over-write bytecode))] + (wrap (case outcome + (#try.Success definition) + file-path + + (#try.Failure error) + error))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux new file mode 100644 index 000000000..37cda09e1 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux @@ -0,0 +1,135 @@ +(.module: + [library + [lux (#- Type) + [abstract + ["." monad (#+ do)]] + [data + [number + ["." i32] + ["n" nat]] + [collection + ["." list ("#\." monoid functor)] + ["." row]] + ["." format #_ + ["#" binary]]] + [target + [jvm + ["." version] + ["." modifier (#+ Modifier) ("#\." monoid)] + ["." field (#+ Field)] + ["." method (#+ Method)] + ["_" bytecode (#+ Label Bytecode) ("#\." monad)] + ["." class (#+ Class)] + ["." type (#+ Type) + [category (#+ Return' Value')] + ["." reflection]] + ["." constant + [pool (#+ Resource)]] + [encoding + ["." name (#+ External Internal)] + ["." unsigned]]]] + [tool + [compiler + [meta + ["." archive (#+ Archive)]]]]]] + ["." / #_ + ["#." abstract] + [field + [constant + ["#." arity]] + [variable + ["#." foreign] + ["#." partial]]] + [method + ["#." init] + ["#." new] + ["#." implementation] + ["#." reset] + ["#." apply]] + ["/#" // #_ + ["#." runtime (#+ Operation Phase Generator)] + [//// + [analysis (#+ Environment)] + [synthesis (#+ Synthesis Abstraction Apply)] + ["." generation] + [/// + ["." arity (#+ Arity)] + ["." phase] + [reference + [variable (#+ Register)]]]]]]) + +(def: #export (with generate archive @begin class environment arity body) + (-> Phase Archive Label External (Environment Synthesis) Arity (Bytecode Any) + (Operation [(List (Resource Field)) + (List (Resource Method)) + (Bytecode Any)])) + (let [classT (type.class class (list)) + fields (: (List (Resource Field)) + (list& /arity.constant + (list\compose (/foreign.variables environment) + (/partial.variables arity)))) + methods (: (List (Resource Method)) + (list& (/init.method classT environment arity) + (/reset.method classT environment arity) + (if (arity.multiary? arity) + (|> (n.min arity /arity.maximum) + list.indices + (list\map (|>> inc (/apply.method classT environment arity @begin body))) + (list& (/implementation.method arity @begin body))) + (list (/implementation.method' //runtime.apply::name arity @begin body)))))] + (do phase.monad + [instance (/new.instance generate archive classT environment arity)] + (wrap [fields methods instance])))) + +(def: modifier + (Modifier Class) + ($_ modifier\compose + class.public + class.final)) + +(def: this-offset 1) + +(def: internal + (All [category] + (-> (Type (<| Return' Value' category)) + Internal)) + (|>> type.reflection reflection.reflection name.internal)) + +(def: #export (abstraction generate archive [environment arity bodyS]) + (Generator Abstraction) + (do phase.monad + [@begin //runtime.forge-label + [function-context bodyG] (generation.with-new-context archive + (generation.with-anchor [@begin ..this-offset] + (generate archive bodyS))) + #let [function-class (//runtime.class-name function-context)] + [fields methods instance] (..with generate archive @begin function-class environment arity bodyG) + class (phase.lift (class.class version.v6_0 + ..modifier + (name.internal function-class) + (..internal /abstract.class) (list) + fields + methods + (row.row))) + #let [bytecode (format.run class.writer class)] + _ (generation.execute! [function-class bytecode]) + _ (generation.save! function-class [function-class bytecode])] + (wrap instance))) + +(def: #export (apply generate archive [abstractionS inputsS]) + (Generator Apply) + (do {! phase.monad} + [abstractionG (generate archive abstractionS) + inputsG (monad.map ! (generate archive) inputsS)] + (wrap ($_ _.compose + abstractionG + (|> inputsG + (list.chunk /arity.maximum) + (monad.map _.monad + (function (_ batchG) + ($_ _.compose + (_.checkcast /abstract.class) + (monad.seq _.monad batchG) + (_.invokevirtual /abstract.class //runtime.apply::name (//runtime.apply::type (list.size batchG))) + )))) + )))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux new file mode 100644 index 000000000..fea8a985e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux @@ -0,0 +1,24 @@ +(.module: + [library + [lux (#- Type) + [data + [text + ["%" format]]] + [target + [jvm + ["." type (#+ Type) + [category (#+ Method)]]]]]] + [// + [field + [constant + ["." arity]]]]) + +(def: #export artifact_id + 1) + +(def: #export class + (type.class (%.nat artifact_id) (list))) + +(def: #export init + (Type Method) + (type.method [(list arity.type) type.void (list)])) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux new file mode 100644 index 000000000..d6bb70600 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux @@ -0,0 +1,26 @@ +(.module: + [library + [lux (#- Type type) + [data + [collection + ["." row]]] + [target + [jvm + ["." field (#+ Field)] + ["." modifier (#+ Modifier) ("#\." monoid)] + [type (#+ Type) + [category (#+ Value)]] + [constant + [pool (#+ Resource)]]]]]]) + +(def: modifier + (Modifier Field) + ($_ modifier\compose + field.public + field.static + field.final + )) + +(def: #export (constant name type) + (-> Text (Type Value) (Resource Field)) + (field.field ..modifier name type (row.row))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux new file mode 100644 index 000000000..a1e0a589d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux @@ -0,0 +1,22 @@ +(.module: + [library + [lux (#- type) + [target + [jvm + ["." type] + ["." field (#+ Field)] + [constant + [pool (#+ Resource)]]]]]] + ["." // + [///////// + [arity (#+ Arity)]]]) + +(def: #export name "arity") +(def: #export type type.int) + +(def: #export minimum Arity 1) +(def: #export maximum Arity 8) + +(def: #export constant + (Resource Field) + (//.constant ..name ..type)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux new file mode 100644 index 000000000..aa200182d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux @@ -0,0 +1,56 @@ +(.module: + [library + [lux (#- Type type) + [data + [collection + ["." list ("#\." functor)] + ["." row]]] + [target + [jvm + ["." modifier (#+ Modifier) ("#\." monoid)] + ["." field (#+ Field)] + ["_" bytecode (#+ Bytecode)] + [type (#+ Type) + [category (#+ Value Class)]] + [constant + [pool (#+ Resource)]]]]]] + ["." //// #_ + ["#." type] + ["#." reference] + [////// + [reference + [variable (#+ Register)]]]]) + +(def: #export type ////type.value) + +(def: #export (get class name) + (-> (Type Class) Text (Bytecode Any)) + ($_ _.compose + ////reference.this + (_.getfield class name ..type) + )) + +(def: #export (put naming class register value) + (-> (-> Register Text) (Type Class) Register (Bytecode Any) (Bytecode Any)) + ($_ _.compose + ////reference.this + value + (_.putfield class (naming register) ..type))) + +(def: modifier + (Modifier Field) + ($_ modifier\compose + field.private + field.final + )) + +(def: #export (variable name type) + (-> Text (Type Value) (Resource Field)) + (field.field ..modifier name type (row.row))) + +(def: #export (variables naming amount) + (-> (-> Register Text) Nat (List (Resource Field))) + (|> amount + list.indices + (list\map (function (_ register) + (..variable (naming register) ..type))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux new file mode 100644 index 000000000..4506bb2f8 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux @@ -0,0 +1,40 @@ +(.module: + [library + [lux (#- Type) + [data + [collection + ["." list] + ["." row]]] + [target + [jvm + ["_" bytecode (#+ Bytecode)] + ["." field (#+ Field)] + [constant + [pool (#+ Resource)]] + [type (#+ Type) + [category (#+ Value Class)]]]]]] + ["." // + ["///#" //// #_ + ["#." reference] + [//// + [analysis (#+ Environment)] + [synthesis (#+ Synthesis)] + [/// + [reference + [variable (#+ Register)]]]]]]) + +(def: #export (closure environment) + (-> (Environment Synthesis) (List (Type Value))) + (list.repeat (list.size environment) //.type)) + +(def: #export (get class register) + (-> (Type Class) Register (Bytecode Any)) + (//.get class (/////reference.foreign-name register))) + +(def: #export (put class register value) + (-> (Type Class) Register (Bytecode Any) (Bytecode Any)) + (//.put /////reference.foreign-name class register value)) + +(def: #export variables + (-> (Environment Synthesis) (List (Resource Field))) + (|>> list.size (//.variables /////reference.foreign-name))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux new file mode 100644 index 000000000..0a2e25b3d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux @@ -0,0 +1,59 @@ +(.module: + [library + [lux (#- Type) + [abstract + ["." monad]] + [data + [number + ["n" nat]] + [collection + ["." list ("#\." functor)] + ["." row]]] + [target + [jvm + ["." field (#+ Field)] + ["_" bytecode (#+ Label Bytecode) ("#\." monad)] + [type (#+ Type) + [category (#+ Class)]] + [constant + [pool (#+ Resource)]]]]]] + ["." / #_ + ["#." count] + ["/#" // + ["/#" // #_ + [constant + ["#." arity]] + ["//#" /// #_ + ["#." reference] + [////// + ["." arity (#+ Arity)] + [reference + [variable (#+ Register)]]]]]]]) + +(def: #export (initial amount) + (-> Nat (Bytecode Any)) + ($_ _.compose + (|> _.aconst-null + (list.repeat amount) + (monad.seq _.monad)) + (_\wrap []))) + +(def: #export (get class register) + (-> (Type Class) Register (Bytecode Any)) + (//.get class (/////reference.partial-name register))) + +(def: #export (put class register value) + (-> (Type Class) Register (Bytecode Any) (Bytecode Any)) + (//.put /////reference.partial-name class register value)) + +(def: #export variables + (-> Arity (List (Resource Field))) + (|>> (n.- ///arity.minimum) (//.variables /////reference.partial-name))) + +(def: #export (new arity) + (-> Arity (Bytecode Any)) + (if (arity.multiary? arity) + ($_ _.compose + /count.initial + (initial (n.- ///arity.minimum arity))) + (_\wrap []))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux new file mode 100644 index 000000000..5497cc094 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux @@ -0,0 +1,31 @@ +(.module: + [library + [lux (#- type) + [control + ["." try]] + [target + [jvm + ["_" bytecode (#+ Bytecode)] + [encoding + [name (#+ External)] + ["." signed]] + ["." type]]]]] + ["." ///// #_ + ["#." abstract]]) + +(def: #export field "partials") +(def: #export type type.int) + +(def: #export initial + (Bytecode Any) + (|> +0 signed.s1 try.assume _.bipush)) + +(def: this + _.aload_0) + +(def: #export value + (Bytecode Any) + ($_ _.compose + ..this + (_.getfield /////abstract.class ..field ..type) + )) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux new file mode 100644 index 000000000..9cbde4b63 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux @@ -0,0 +1,14 @@ +(.module: + [library + [lux #* + [target + [jvm + ["." modifier (#+ Modifier) ("#\." monoid)] + ["." method (#+ Method)]]]]]) + +(def: #export modifier + (Modifier Method) + ($_ modifier\compose + method.public + method.strict + )) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux new file mode 100644 index 000000000..e42804d63 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux @@ -0,0 +1,157 @@ +(.module: + [library + [lux (#- Type type) + [abstract + ["." monad (#+ do)]] + [control + ["." try]] + [data + [number + ["n" nat] + ["i" int] + ["." i32]] + [collection + ["." list ("#\." monoid functor)]]] + [target + [jvm + ["_" bytecode (#+ Label Bytecode) ("#\." monad)] + ["." method (#+ Method)] + [constant + [pool (#+ Resource)]] + [encoding + ["." signed]] + ["." type (#+ Type) + ["." category (#+ Class)]]]]]] + ["." // + ["#." reset] + ["#." implementation] + ["#." init] + ["/#" // #_ + ["#." abstract] + [field + [constant + ["#." arity]] + [variable + ["#." partial + ["#/." count]] + ["#." foreign]]] + ["/#" // #_ + ["#." runtime] + ["#." value] + ["#." reference] + [//// + [analysis (#+ Environment)] + [synthesis (#+ Synthesis)] + [/// + [arity (#+ Arity)] + [reference + [variable (#+ Register)]]]]]]]) + +(def: (increment by) + (-> Nat (Bytecode Any)) + ($_ _.compose + (<| _.int .i64 by) + _.iadd)) + +(def: (inputs offset amount) + (-> Register Nat (Bytecode Any)) + ($_ _.compose + (|> amount + list.indices + (monad.map _.monad (|>> (n.+ offset) _.aload))) + (_\wrap []) + )) + +(def: (apply offset amount) + (-> Register Nat (Bytecode Any)) + (let [arity (n.min amount ///arity.maximum)] + ($_ _.compose + (_.checkcast ///abstract.class) + (..inputs offset arity) + (_.invokevirtual ///abstract.class ////runtime.apply::name (////runtime.apply::type arity)) + (if (n.> ///arity.maximum amount) + (apply (n.+ ///arity.maximum offset) + (n.- ///arity.maximum amount)) + (_\wrap [])) + ))) + +(def: this-offset 1) + +(def: #export (method class environment function-arity @begin body apply-arity) + (-> (Type Class) (Environment Synthesis) Arity Label (Bytecode Any) Arity (Resource Method)) + (let [num-partials (dec function-arity) + over-extent (i.- (.int apply-arity) + (.int function-arity))] + (method.method //.modifier ////runtime.apply::name + (////runtime.apply::type apply-arity) + (list) + (#.Some (case num-partials + 0 ($_ _.compose + ////reference.this + (..inputs ..this-offset apply-arity) + (_.invokevirtual class //implementation.name (//implementation.type function-arity)) + _.areturn) + _ (do _.monad + [@default _.new-label + @labelsH _.new-label + @labelsT (|> _.new-label + (list.repeat (dec num-partials)) + (monad.seq _.monad)) + #let [cases (|> (list\compose (#.Cons [@labelsH @labelsT]) + (list @default)) + list.enumeration + (list\map (function (_ [stage @case]) + (let [current-partials (|> (list.indices stage) + (list\map (///partial.get class)) + (monad.seq _.monad)) + already-partial? (n.> 0 stage) + exact-match? (i.= over-extent (.int stage)) + has-more-than-necessary? (i.> over-extent (.int stage))] + ($_ _.compose + (_.set-label @case) + (cond exact-match? + ($_ _.compose + ////reference.this + (if already-partial? + (_.invokevirtual class //reset.name (//reset.type class)) + (_\wrap [])) + current-partials + (..inputs ..this-offset apply-arity) + (_.invokevirtual class //implementation.name (//implementation.type function-arity)) + _.areturn) + + has-more-than-necessary? + (let [inputs-to-completion (|> function-arity (n.- stage)) + inputs-left (|> apply-arity (n.- inputs-to-completion))] + ($_ _.compose + ////reference.this + (_.invokevirtual class //reset.name (//reset.type class)) + current-partials + (..inputs ..this-offset inputs-to-completion) + (_.invokevirtual class //implementation.name (//implementation.type function-arity)) + (apply (n.+ ..this-offset inputs-to-completion) inputs-left) + _.areturn)) + + ## (i.< over-extent (.int stage)) + (let [current-environment (|> (list.indices (list.size environment)) + (list\map (///foreign.get class)) + (monad.seq _.monad)) + missing-partials (|> _.aconst-null + (list.repeat (|> num-partials (n.- apply-arity) (n.- stage))) + (monad.seq _.monad))] + ($_ _.compose + (_.new class) + _.dup + current-environment + ///partial/count.value + (..increment apply-arity) + current-partials + (..inputs ..this-offset apply-arity) + missing-partials + (_.invokevirtual class //init.name (//init.type environment function-arity)) + _.areturn))))))) + (monad.seq _.monad))]] + ($_ _.compose + ///partial/count.value + (_.tableswitch (try.assume (signed.s4 +0)) @default [@labelsH @labelsT]) + cases))))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux new file mode 100644 index 000000000..14cde40a2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux @@ -0,0 +1,42 @@ +(.module: + [library + [lux (#- Type type) + [data + [collection + ["." list]]] + [target + [jvm + ["." method (#+ Method)] + ["_" bytecode (#+ Label Bytecode)] + [constant + [pool (#+ Resource)]] + ["." type (#+ Type) + ["." category]]]]]] + ["." // + ["//#" /// #_ + ["#." type] + [////// + [arity (#+ Arity)]]]]) + +(def: #export name "impl") + +(def: #export (type arity) + (-> Arity (Type category.Method)) + (type.method [(list.repeat arity ////type.value) + ////type.value + (list)])) + +(def: #export (method' name arity @begin body) + (-> Text Arity Label (Bytecode Any) (Resource Method)) + (method.method //.modifier name + (..type arity) + (list) + (#.Some ($_ _.compose + (_.set-label @begin) + body + _.areturn + )))) + +(def: #export method + (-> Arity Label (Bytecode Any) (Resource Method)) + (method' ..name)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux new file mode 100644 index 000000000..3785f9a40 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux @@ -0,0 +1,98 @@ +(.module: + [library + [lux (#- Type type) + [abstract + ["." monad]] + [control + ["." try]] + [data + [number + ["n" nat]] + [collection + ["." list ("#\." monoid functor)]]] + [target + [jvm + ["_" bytecode (#+ Bytecode)] + ["." method (#+ Method)] + [encoding + ["." unsigned]] + [constant + [pool (#+ Resource)]] + ["." type (#+ Type) + ["." category (#+ Class Value)]]]]]] + ["." // + ["#." implementation] + ["/#" // #_ + ["#." abstract] + [field + [constant + ["#." arity]] + [variable + ["#." foreign] + ["#." partial]]] + ["/#" // #_ + ["#." type] + ["#." reference] + [//// + [analysis (#+ Environment)] + [synthesis (#+ Synthesis)] + [/// + ["." arity (#+ Arity)] + [reference + [variable (#+ Register)]]]]]]]) + +(def: #export name "<init>") + +(def: (partials arity) + (-> Arity (List (Type Value))) + (list.repeat (dec arity) ////type.value)) + +(def: #export (type environment arity) + (-> (Environment Synthesis) Arity (Type category.Method)) + (type.method [(list\compose (///foreign.closure environment) + (if (arity.multiary? arity) + (list& ///arity.type (..partials arity)) + (list))) + type.void + (list)])) + +(def: no-partials (|> 0 unsigned.u1 try.assume _.bipush)) + +(def: #export (super environment-size arity) + (-> Nat Arity (Bytecode Any)) + (let [arity-register (inc environment-size)] + ($_ _.compose + (if (arity.unary? arity) + ..no-partials + (_.iload arity-register)) + (_.invokespecial ///abstract.class ..name ///abstract.init)))) + +(def: (store-all amount put offset) + (-> Nat + (-> Register (Bytecode Any) (Bytecode Any)) + (-> Register Register) + (Bytecode Any)) + (|> (list.indices amount) + (list\map (function (_ register) + (put register + (_.aload (offset register))))) + (monad.seq _.monad))) + +(def: #export (method class environment arity) + (-> (Type Class) (Environment Synthesis) Arity (Resource Method)) + (let [environment-size (list.size environment) + offset-foreign (: (-> Register Register) + (n.+ 1)) + offset-arity (: (-> Register Register) + (|>> offset-foreign (n.+ environment-size))) + offset-partial (: (-> Register Register) + (|>> offset-arity (n.+ 1)))] + (method.method //.modifier ..name + (..type environment arity) + (list) + (#.Some ($_ _.compose + ////reference.this + (..super environment-size arity) + (store-all environment-size (///foreign.put class) offset-foreign) + (store-all (dec arity) (///partial.put class) offset-partial) + _.return))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux new file mode 100644 index 000000000..f6bfa0278 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux @@ -0,0 +1,81 @@ +(.module: + [library + [lux (#- Type type) + [abstract + ["." monad (#+ do)]] + [data + [number + ["n" nat]] + [collection + ["." list]]] + [target + [jvm + ["." field (#+ Field)] + ["." method (#+ Method)] + ["_" bytecode (#+ Bytecode)] + ["." constant + [pool (#+ Resource)]] + [type (#+ Type) + ["." category (#+ Class Value Return)]]]] + [tool + [compiler + [meta + ["." archive (#+ Archive)]]]]]] + ["." // + ["#." init] + ["#." implementation] + ["/#" // #_ + [field + [constant + ["#." arity]] + [variable + ["#." foreign] + ["#." partial]]] + ["/#" // #_ + [runtime (#+ Operation Phase)] + ["#." value] + ["#." reference] + [//// + [analysis (#+ Environment)] + [synthesis (#+ Synthesis)] + [/// + ["." arity (#+ Arity)] + ["." phase]]]]]]) + +(def: #export (instance' foreign-setup class environment arity) + (-> (List (Bytecode Any)) (Type Class) (Environment Synthesis) Arity (Bytecode Any)) + ($_ _.compose + (_.new class) + _.dup + (monad.seq _.monad foreign-setup) + (///partial.new arity) + (_.invokespecial class //init.name (//init.type environment arity)))) + +(def: #export (instance generate archive class environment arity) + (-> Phase Archive (Type Class) (Environment Synthesis) Arity (Operation (Bytecode Any))) + (do {! phase.monad} + [foreign* (monad.map ! (generate archive) environment)] + (wrap (instance' foreign* class environment arity)))) + +(def: #export (method class environment arity) + (-> (Type Class) (Environment Synthesis) Arity (Resource Method)) + (let [after-this (: (-> Nat Nat) + (n.+ 1)) + environment-size (list.size environment) + after-environment (: (-> Nat Nat) + (|>> after-this (n.+ environment-size))) + after-arity (: (-> Nat Nat) + (|>> after-environment (n.+ 1)))] + (method.method //.modifier //init.name + (//init.type environment arity) + (list) + (#.Some ($_ _.compose + ////reference.this + (//init.super environment-size arity) + (monad.map _.monad (function (_ register) + (///foreign.put class register (_.aload (after-this register)))) + (list.indices environment-size)) + (monad.map _.monad (function (_ register) + (///partial.put class register (_.aload (after-arity register)))) + (list.indices (n.- ///arity.minimum arity))) + _.areturn))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux new file mode 100644 index 000000000..229538870 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux @@ -0,0 +1,50 @@ +(.module: + [library + [lux (#- Type type) + [data + [collection + ["." list ("#\." functor)]]] + [target + [jvm + ["." method (#+ Method)] + ["_" bytecode (#+ Bytecode)] + [constant + [pool (#+ Resource)]] + ["." type (#+ Type) + ["." category (#+ Class)]]]]]] + ["." // + ["#." new] + ["/#" // #_ + [field + [variable + ["#." foreign]]] + ["/#" // #_ + ["#." reference] + [//// + [analysis (#+ Environment)] + [synthesis (#+ Synthesis)] + [/// + ["." arity (#+ Arity)]]]]]]) + +(def: #export name "reset") + +(def: #export (type class) + (-> (Type Class) (Type category.Method)) + (type.method [(list) class (list)])) + +(def: (current-environment class) + (-> (Type Class) (Environment Synthesis) (List (Bytecode Any))) + (|>> list.size + list.indices + (list\map (///foreign.get class)))) + +(def: #export (method class environment arity) + (-> (Type Class) (Environment Synthesis) Arity (Resource Method)) + (method.method //.modifier ..name + (..type class) + (list) + (#.Some ($_ _.compose + (if (arity.multiary? arity) + (//new.instance' (..current-environment class environment) class environment arity) + ////reference.this) + _.areturn)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux new file mode 100644 index 000000000..2f6b8041c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux @@ -0,0 +1,161 @@ +(.module: + [library + [lux (#- Definition) + ["." ffi (#+ import: do-to object)] + [abstract + [monad (#+ do)]] + [control + pipe + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["." io (#+ IO io)] + [concurrency + ["." atom (#+ Atom atom)]]] + [data + [binary (#+ Binary)] + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)]] + [collection + ["." array] + ["." dictionary (#+ Dictionary)] + ["." row]] + ["." format #_ + ["#" binary]]] + [target + [jvm + ["." loader (#+ Library)] + ["_" bytecode (#+ Bytecode)] + ["." modifier (#+ Modifier) ("#\." monoid)] + ["." field (#+ Field)] + ["." method (#+ Method)] + ["." version] + ["." class (#+ Class)] + ["." encoding #_ + ["#/." name]] + ["." type + ["." descriptor]]]] + [tool + [compiler + ["." name]]]]] + ["." // #_ + ["#." runtime (#+ Definition)]] + ) + +(import: java/lang/reflect/Field + (get [#? java/lang/Object] #try #? java/lang/Object)) + +(import: (java/lang/Class a) + (getField [java/lang/String] #try java/lang/reflect/Field)) + +(import: java/lang/Object + (getClass [] (java/lang/Class java/lang/Object))) + +(import: java/lang/ClassLoader) + +(def: value::field "value") +(def: value::type (type.class "java.lang.Object" (list))) +(def: value::modifier ($_ modifier\compose field.public field.final field.static)) + +(def: init::type (type.method [(list) type.void (list)])) +(def: init::modifier ($_ modifier\compose method.public method.static method.strict)) + +(exception: #export (cannot-load {class Text} {error Text}) + (exception.report + ["Class" class] + ["Error" error])) + +(exception: #export (invalid-field {class Text} {field Text} {error Text}) + (exception.report + ["Class" class] + ["Field" field] + ["Error" error])) + +(exception: #export (invalid-value {class Text}) + (exception.report + ["Class" class])) + +(def: (class-value class-name class) + (-> Text (java/lang/Class java/lang/Object) (Try Any)) + (case (java/lang/Class::getField ..value::field class) + (#try.Success field) + (case (java/lang/reflect/Field::get #.None field) + (#try.Success ?value) + (case ?value + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..invalid-value [class-name])) + + (#try.Failure error) + (exception.throw ..cannot-load [class-name error])) + + (#try.Failure error) + (exception.throw ..invalid-field [class-name ..value::field error]))) + +(def: class-path-separator ".") + +(def: (evaluate! library loader eval-class valueG) + (-> Library java/lang/ClassLoader Text (Bytecode Any) (Try [Any Definition])) + (let [bytecode-name (text.replace-all class-path-separator .module-separator eval-class) + bytecode (class.class version.v6_0 + class.public + (encoding/name.internal bytecode-name) + (encoding/name.internal "java.lang.Object") (list) + (list (field.field ..value::modifier ..value::field ..value::type (row.row))) + (list (method.method ..init::modifier "<clinit>" ..init::type + (list) + (#.Some + ($_ _.compose + valueG + (_.putstatic (type.class bytecode-name (list)) ..value::field ..value::type) + _.return)))) + (row.row))] + (io.run (do {! (try.with io.monad)} + [bytecode (\ ! map (format.run class.writer) + (io.io bytecode)) + _ (loader.store eval-class bytecode library) + class (loader.load eval-class loader) + value (\ io.monad wrap (class-value eval-class class))] + (wrap [value + [eval-class bytecode]]))))) + +(def: (execute! library loader temp-label [class-name class-bytecode]) + (-> Library java/lang/ClassLoader Text Definition (Try Any)) + (io.run (do (try.with io.monad) + [existing-class? (|> (atom.read library) + (\ io.monad map (function (_ library) + (dictionary.key? library class-name))) + (try.lift io.monad) + (: (IO (Try Bit)))) + _ (if existing-class? + (wrap []) + (loader.store class-name class-bytecode library))] + (loader.load class-name loader)))) + +(def: (define! library loader [module name] valueG) + (-> Library java/lang/ClassLoader Name (Bytecode Any) (Try [Text Any Definition])) + (let [class-name (format (text.replace-all .module-separator class-path-separator module) + class-path-separator (name.normalize name) + "___" (%.nat (text\hash name)))] + (do try.monad + [[value definition] (evaluate! library loader class-name valueG)] + (wrap [class-name value definition])))) + +(def: #export host + (IO //runtime.Host) + (io (let [library (loader.new-library []) + loader (loader.memory library)] + (: //runtime.Host + (implementation + (def: (evaluate! temp-label valueG) + (let [eval-class (|> temp-label name.normalize (text.replace-all " " "$"))] + (\ try.monad map product.left + (..evaluate! library loader eval-class valueG)))) + + (def: execute! + (..execute! library loader)) + + (def: define! + (..define! library loader))))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux new file mode 100644 index 000000000..465e8d1af --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux @@ -0,0 +1,90 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function]] + [data + ["." product] + [number + ["n" nat]] + [collection + ["." list ("#\." functor)]]] + [target + [jvm + ["_" bytecode (#+ Label Bytecode) ("#\." monad)]]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." value] + [//// + ["." synthesis (#+ Path Synthesis)] + ["." generation] + [/// + ["." phase] + [reference + [variable (#+ Register)]]]]]) + +(def: (invariant? register changeS) + (-> Register Synthesis Bit) + (case changeS + (^ (synthesis.variable/local var)) + (n.= register var) + + _ + false)) + +(def: no-op + (_\wrap [])) + +(def: #export (recur translate archive updatesS) + (Generator (List Synthesis)) + (do {! phase.monad} + [[@begin offset] generation.anchor + updatesG (|> updatesS + list.enumeration + (list\map (function (_ [index updateS]) + [(n.+ offset index) updateS])) + (monad.map ! (function (_ [register updateS]) + (if (invariant? register updateS) + (wrap [..no-op + ..no-op]) + (do ! + [fetchG (translate archive updateS) + #let [storeG (_.astore register)]] + (wrap [fetchG storeG]))))))] + (wrap ($_ _.compose + ## It may look weird that first I fetch all the values separately, + ## and then I store them all. + ## It must be done that way in order to avoid a potential bug. + ## Let's say that you'll recur with 2 expressions: X and Y. + ## If Y depends on the value of X, and you don't perform fetches + ## and stores separately, then by the time Y is evaluated, it + ## will refer to the new value of X, instead of the old value, as + ## should be the case. + (|> updatesG + (list\map product.left) + (monad.seq _.monad)) + (|> updatesG + list.reverse + (list\map product.right) + (monad.seq _.monad)) + (_.goto @begin))))) + +(def: #export (scope translate archive [offset initsS+ iterationS]) + (Generator [Nat (List Synthesis) Synthesis]) + (do {! phase.monad} + [@begin //runtime.forge-label + initsI+ (monad.map ! (translate archive) initsS+) + iterationG (generation.with-anchor [@begin offset] + (translate archive iterationS)) + #let [initializationG (|> (list.enumeration initsI+) + (list\map (function (_ [index initG]) + ($_ _.compose + initG + (_.astore (n.+ offset index))))) + (monad.seq _.monad))]] + (wrap ($_ _.compose + initializationG + (_.set-label @begin) + iterationG)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux new file mode 100644 index 000000000..6b24fb2f5 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux @@ -0,0 +1,121 @@ +(.module: + [library + [lux (#- i64) + ["." ffi (#+ import:)] + [abstract + [monad (#+ do)]] + [target + [jvm + ["_" bytecode (#+ Bytecode)] + ["." type] + [encoding + ["." signed]]]]]] + ["." // #_ + ["#." runtime]]) + +(def: $Boolean (type.class "java.lang.Boolean" (list))) +(def: $Long (type.class "java.lang.Long" (list))) +(def: $Double (type.class "java.lang.Double" (list))) + +(def: #export (bit value) + (-> Bit (Bytecode Any)) + (_.getstatic $Boolean (if value "TRUE" "FALSE") $Boolean)) + +(def: wrap-i64 + (_.invokestatic $Long "valueOf" (type.method [(list type.long) $Long (list)]))) + +(def: #export (i64 value) + (-> (I64 Any) (Bytecode Any)) + (case (.int value) + (^template [<int> <instruction>] + [<int> + (do _.monad + [_ <instruction>] + ..wrap-i64)]) + ([+0 _.lconst-0] + [+1 _.lconst-1]) + + (^template [<int> <instruction>] + [<int> + (do _.monad + [_ <instruction> + _ _.i2l] + ..wrap-i64)]) + ([-1 _.iconst-m1] + ## [+0 _.iconst-0] + ## [+1 _.iconst-1] + [+2 _.iconst-2] + [+3 _.iconst-3] + [+4 _.iconst-4] + [+5 _.iconst-5]) + + value + (case (signed.s1 value) + (#try.Success value) + (do _.monad + [_ (_.bipush value) + _ _.i2l] + ..wrap-i64) + + (#try.Failure _) + (case (signed.s2 value) + (#try.Success value) + (do _.monad + [_ (_.sipush value) + _ _.i2l] + ..wrap-i64) + + (#try.Failure _) + (do _.monad + [_ (_.long value)] + ..wrap-i64))))) + +(def: wrap-f64 + (_.invokestatic $Double "valueOf" (type.method [(list type.double) $Double (list)]))) + +(import: java/lang/Double + (#static doubleToRawLongBits #manual [double] int)) + +(def: #export (f64 value) + (-> Frac (Bytecode Any)) + (case value + (^template [<int> <instruction>] + [<int> + (do _.monad + [_ <instruction>] + ..wrap-f64)]) + ([+1.0 _.dconst-1]) + + (^template [<int> <instruction>] + [<int> + (do _.monad + [_ <instruction> + _ _.f2d] + ..wrap-f64)]) + ([+2.0 _.fconst-2]) + + (^template [<int> <instruction>] + [<int> + (do _.monad + [_ <instruction> + _ _.i2d] + ..wrap-f64)]) + ([-1.0 _.iconst-m1] + ## [+0.0 _.iconst-0] + ## [+1.0 _.iconst-1] + [+2.0 _.iconst-2] + [+3.0 _.iconst-3] + [+4.0 _.iconst-4] + [+5.0 _.iconst-5]) + + _ + (let [constantI (if (i.= ..d0-bits + (java/lang/Double::doubleToRawLongBits (:as java/lang/Double value))) + _.dconst-0 + (_.double value))] + (do _.monad + [_ constantI] + ..wrap-f64)))) + +(def: #export text + _.string) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux new file mode 100644 index 000000000..0441f3b00 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux @@ -0,0 +1,144 @@ +(.module: + [library + [lux (#- Definition) + [abstract + [monad (#+ do)]] + [control + ["." try]] + [data + [collection + ["." row]] + ["." format #_ + ["#" binary]]] + [target + [jvm + ["_" bytecode (#+ Bytecode)] + ["." modifier (#+ Modifier) ("#\." monoid)] + ["." method (#+ Method)] + ["." version] + ["." class (#+ Class)] + [encoding + ["." name]] + ["." type + ["." reflection]]]]]] + ["." // + ["#." runtime (#+ Definition)] + ["#." function/abstract]]) + +(def: #export class "LuxProgram") + +(def: ^Object (type.class "java.lang.Object" (list))) +(def: ^String (type.class "java.lang.String" (list))) +(def: ^Args (type.array ^String)) + +(def: main::type (type.method [(list ..^Args) type.void (list)])) + +(def: main::modifier + (Modifier Method) + ($_ modifier\compose + method.public + method.static + method.strict + )) + +(def: program::modifier + (Modifier Class) + ($_ modifier\compose + class.public + class.final + )) + +(def: nil //runtime.none-injection) + +(def: amount-of-inputs + (Bytecode Any) + ($_ _.compose + _.aload-0 + _.arraylength)) + +(def: decrease + (Bytecode Any) + ($_ _.compose + _.iconst-1 + _.isub)) + +(def: head + (Bytecode Any) + ($_ _.compose + _.dup + _.aload-0 + _.swap + _.aaload + _.swap + _.dup-x2 + _.pop)) + +(def: pair + (Bytecode Any) + ($_ _.compose + _.iconst-2 + (_.anewarray ^Object) + _.dup-x1 + _.swap + _.iconst-0 + _.swap + _.aastore + _.dup-x1 + _.swap + _.iconst-1 + _.swap + _.aastore)) + +(def: cons //runtime.right-injection) + +(def: input-list + (Bytecode Any) + (do _.monad + [@loop _.new-label + @end _.new-label] + ($_ _.compose + ..nil + ..amount-of-inputs + (_.set-label @loop) + ..decrease + _.dup + (_.iflt @end) + ..head + ..pair + ..cons + _.swap + (_.goto @loop) + (_.set-label @end) + _.pop))) + +(def: feed-inputs //runtime.apply) + +(def: run-io + (Bytecode Any) + ($_ _.compose + (_.checkcast //function/abstract.class) + _.aconst-null + //runtime.apply)) + +(def: #export (program program) + (-> (Bytecode Any) Definition) + (let [super-class (|> ..^Object type.reflection reflection.reflection name.internal) + main (method.method ..main::modifier "main" ..main::type + (list) + (#.Some ($_ _.compose + program + ..input-list + ..feed-inputs + ..run-io + _.return)))] + [..class + (<| (format.run class.writer) + try.assume + (class.class version.v6_0 + ..program::modifier + (name.internal ..class) + super-class + (list) + (list) + (list main) + (row.row)))])) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux new file mode 100644 index 000000000..c41e5c16a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux @@ -0,0 +1,67 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [data + [text + ["%" format (#+ format)]]] + [target + [jvm + ["_" bytecode (#+ Bytecode)] + ["." type] + [encoding + ["." unsigned]]]]]] + ["." // #_ + ["#." runtime (#+ Operation)] + ["#." value] + ["#." type] + ["//#" /// #_ + [// + ["." generation] + [/// + ["#" phase ("operation\." monad)] + [reference + ["." variable (#+ Register Variable)]] + [meta + [archive (#+ Archive)]]]]]]) + +(def: #export this + (Bytecode Any) + _.aload-0) + +(template [<name> <prefix>] + [(def: #export <name> + (-> Register Text) + (|>> %.nat (format <prefix>)))] + + [foreign-name "f"] + [partial-name "p"] + ) + +(def: (foreign archive variable) + (-> Archive Register (Operation (Bytecode Any))) + (do {! ////.monad} + [bytecode-name (\ ! map //runtime.class-name + (generation.context archive))] + (wrap ($_ _.compose + ..this + (_.getfield (type.class bytecode-name (list)) + (..foreign-name variable) + //type.value))))) + +(def: #export (variable archive variable) + (-> Archive Variable (Operation (Bytecode Any))) + (case variable + (#variable.Local variable) + (operation\wrap (_.aload variable)) + + (#variable.Foreign variable) + (..foreign archive variable))) + +(def: #export (constant archive name) + (-> Archive Name (Operation (Bytecode Any))) + (do {! ////.monad} + [bytecode-name (\ ! map //runtime.class-name + (generation.remember archive name))] + (wrap (_.getstatic (type.class bytecode-name (list)) //value.field //type.value)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux new file mode 100644 index 000000000..e445ec2d4 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux @@ -0,0 +1,611 @@ +(.module: + [library + [lux (#- Type Definition case false true try) + [abstract + ["." monad (#+ do)] + ["." enum]] + [control + ["." try]] + [data + [binary (#+ Binary)] + [collection + ["." list ("#\." functor)] + ["." row]] + ["." format #_ + ["#" binary]] + [text + ["%" format (#+ format)]]] + [math + [number + ["n" nat] + ["." i32] + ["." i64]]] + [target + ["." jvm #_ + ["_" bytecode (#+ Label Bytecode)] + ["." modifier (#+ Modifier) ("#\." monoid)] + ["." field (#+ Field)] + ["." method (#+ Method)] + ["#/." version] + ["." class (#+ Class)] + ["." constant + [pool (#+ Resource)]] + [encoding + ["." name]] + ["." type (#+ Type) + ["." category (#+ Return' Value')] + ["." reflection]]]]]] + ["." // #_ + ["#." type] + ["#." value] + ["#." function #_ + ["#" abstract] + [field + [constant + ["#/." arity]] + [variable + [partial + ["#/." count]]]]] + ["//#" /// #_ + [// + ["." version] + ["." synthesis] + ["." generation] + [/// + ["#" phase] + [arity (#+ Arity)] + [reference + [variable (#+ Register)]] + [meta + [io (#+ lux_context)] + [archive (#+ Archive)]]]]]]) + +(type: #export Byte_Code Binary) + +(type: #export Definition [Text Byte_Code]) + +(type: #export Anchor [Label Register]) + +(template [<name> <base>] + [(type: #export <name> + (<base> Anchor (Bytecode Any) Definition))] + + [Operation generation.Operation] + [Phase generation.Phase] + [Handler generation.Handler] + [Bundle generation.Bundle] + ) + +(type: #export (Generator i) + (-> Phase Archive i (Operation (Bytecode Any)))) + +(type: #export Host + (generation.Host (Bytecode Any) Definition)) + +(def: #export (class_name [module id]) + (-> generation.Context Text) + (format lux_context + "/" (%.nat version.version) + "/" (%.nat module) + "/" (%.nat id))) + +(def: artifact_id + 0) + +(def: #export class + (type.class (%.nat ..artifact_id) (list))) + +(def: procedure + (-> Text (Type category.Method) (Bytecode Any)) + (_.invokestatic ..class)) + +(def: modifier + (Modifier Method) + ($_ modifier\compose + method.public + method.static + method.strict + )) + +(def: this + (Bytecode Any) + _.aload_0) + +(def: #export (get index) + (-> (Bytecode Any) (Bytecode Any)) + ($_ _.compose + index + _.aaload)) + +(def: (set! index value) + (-> (Bytecode Any) (Bytecode Any) (Bytecode Any)) + ($_ _.compose + ## A + _.dup ## AA + index ## AAI + value ## AAIV + _.aastore ## A + )) + +(def: #export unit (_.string synthesis.unit)) + +(def: variant::name "variant") +(def: variant::type (type.method [(list //type.tag //type.flag //type.value) //type.variant (list)])) +(def: #export variant (..procedure ..variant::name ..variant::type)) + +(def: variant_tag _.iconst_0) +(def: variant_last? _.iconst_1) +(def: variant_value _.iconst_2) + +(def: variant::method + (let [new_variant ($_ _.compose + _.iconst_3 + (_.anewarray //type.value)) + $tag ($_ _.compose + _.iload_0 + (//value.wrap type.int)) + $last? _.aload_1 + $value _.aload_2] + (method.method ..modifier ..variant::name + ..variant::type + (list) + (#.Some ($_ _.compose + new_variant ## A[3] + (..set! ..variant_tag $tag) ## A[3] + (..set! ..variant_last? $last?) ## A[3] + (..set! ..variant_value $value) ## A[3] + _.areturn))))) + +(def: #export left_flag _.aconst_null) +(def: #export right_flag ..unit) + +(def: #export left_injection + (Bytecode Any) + ($_ _.compose + _.iconst_0 + ..left_flag + _.dup2_x1 + _.pop2 + ..variant)) + +(def: #export right_injection + (Bytecode Any) + ($_ _.compose + _.iconst_1 + ..right_flag + _.dup2_x1 + _.pop2 + ..variant)) + +(def: #export some_injection ..right_injection) + +(def: #export none_injection + (Bytecode Any) + ($_ _.compose + _.iconst_0 + ..left_flag + ..unit + ..variant)) + +(def: (risky $unsafe) + (-> (Bytecode Any) (Bytecode Any)) + (do _.monad + [@try _.new_label + @handler _.new_label] + ($_ _.compose + (_.try @try @handler @handler //type.error) + (_.set_label @try) + $unsafe + ..some_injection + _.areturn + (_.set_label @handler) + ..none_injection + _.areturn + ))) + +(def: decode_frac::name "decode_frac") +(def: decode_frac::type (type.method [(list //type.text) //type.variant (list)])) +(def: #export decode_frac (..procedure ..decode_frac::name ..decode_frac::type)) + +(def: decode_frac::method + (method.method ..modifier ..decode_frac::name + ..decode_frac::type + (list) + (#.Some + (..risky + ($_ _.compose + _.aload_0 + (_.invokestatic //type.frac "parseDouble" (type.method [(list //type.text) type.double (list)])) + (//value.wrap type.double) + ))))) + +(def: #export log! + (Bytecode Any) + (let [^PrintStream (type.class "java.io.PrintStream" (list)) + ^System (type.class "java.lang.System" (list)) + out (_.getstatic ^System "out" ^PrintStream) + print_type (type.method [(list //type.value) type.void (list)]) + print! (function (_ method) (_.invokevirtual ^PrintStream method print_type))] + ($_ _.compose + out (_.string "LUX LOG: ") (print! "print") + out _.swap (print! "println")))) + +(def: exception_constructor (type.method [(list //type.text) type.void (list)])) +(def: (illegal_state_exception message) + (-> Text (Bytecode Any)) + (let [^IllegalStateException (type.class "java.lang.IllegalStateException" (list))] + ($_ _.compose + (_.new ^IllegalStateException) + _.dup + (_.string message) + (_.invokespecial ^IllegalStateException "<init>" ..exception_constructor)))) + +(def: failure::type + (type.method [(list) type.void (list)])) + +(def: (failure name message) + (-> Text Text (Resource Method)) + (method.method ..modifier name + ..failure::type + (list) + (#.Some + ($_ _.compose + (..illegal_state_exception message) + _.athrow)))) + +(def: pm_failure::name "pm_failure") +(def: #export pm_failure (..procedure ..pm_failure::name ..failure::type)) + +(def: pm_failure::method + (..failure ..pm_failure::name "Invalid expression for pattern-matching.")) + +(def: #export stack_head _.iconst_0) +(def: #export stack_tail _.iconst_1) + +(def: push::name "push") +(def: push::type (type.method [(list //type.stack //type.value) //type.stack (list)])) +(def: #export push (..procedure ..push::name ..push::type)) + +(def: push::method + (method.method ..modifier ..push::name + ..push::type + (list) + (#.Some + (let [new_stack_frame! ($_ _.compose + _.iconst_2 + (_.anewarray //type.value)) + $head _.aload_1 + $tail _.aload_0] + ($_ _.compose + new_stack_frame! + (..set! ..stack_head $head) + (..set! ..stack_tail $tail) + _.areturn))))) + +(def: case::name "case") +(def: case::type (type.method [(list //type.variant //type.tag //type.flag) //type.value (list)])) +(def: #export case (..procedure ..case::name ..case::type)) + +(def: case::method + (method.method ..modifier ..case::name ..case::type + (list) + (#.Some + (do _.monad + [@loop _.new_label + @perfect_match! _.new_label + @tags_match! _.new_label + @maybe_nested _.new_label + @mismatch! _.new_label + #let [::tag ($_ _.compose + (..get ..variant_tag) + (//value.unwrap type.int)) + ::last? (..get ..variant_last?) + ::value (..get ..variant_value) + + $variant _.aload_0 + $tag _.iload_1 + $last? _.aload_2 + + not_found _.aconst_null + + update_$tag _.isub + update_$variant ($_ _.compose + $variant ::value + (_.checkcast //type.variant) + _.astore_0) + recur (: (-> Label (Bytecode Any)) + (function (_ @loop_start) + ($_ _.compose + ## tag, sumT + update_$variant ## tag, sumT + update_$tag ## sub_tag + (_.goto @loop_start)))) + + super_nested_tag ($_ _.compose + ## tag, sumT + _.swap ## sumT, tag + _.isub) + super_nested ($_ _.compose + ## tag, sumT + super_nested_tag ## super_tag + $variant ::last? ## super_tag, super_last + $variant ::value ## super_tag, super_last, super_value + ..variant)]] + ($_ _.compose + $tag + (_.set_label @loop) + $variant ::tag + _.dup2 (_.if_icmpeq @tags_match!) + _.dup2 (_.if_icmpgt @maybe_nested) + $last? (_.ifnull @mismatch!) ## tag, sumT + super_nested ## super_variant + _.areturn + (_.set_label @tags_match!) ## tag, sumT + $last? ## tag, sumT, wants_last? + $variant ::last? ## tag, sumT, wants_last?, is_last? + (_.if_acmpeq @perfect_match!) ## tag, sumT + (_.set_label @maybe_nested) ## tag, sumT + $variant ::last? ## tag, sumT, last? + (_.ifnull @mismatch!) ## tag, sumT + (recur @loop) + (_.set_label @perfect_match!) ## tag, sumT + ## _.pop2 + $variant ::value + _.areturn + (_.set_label @mismatch!) ## tag, sumT + ## _.pop2 + not_found + _.areturn + ))))) + +(def: projection_type (type.method [(list //type.tuple //type.offset) //type.value (list)])) + +(def: left_projection::name "left") +(def: #export left_projection (..procedure ..left_projection::name ..projection_type)) + +(def: right_projection::name "right") +(def: #export right_projection (..procedure ..right_projection::name ..projection_type)) + +(def: projection::method2 + [(Resource Method) (Resource Method)] + (let [$tuple _.aload_0 + $tuple::size ($_ _.compose + $tuple _.arraylength) + + $lefts _.iload_1 + + $last_right ($_ _.compose + $tuple::size _.iconst_1 _.isub) + + update_$lefts ($_ _.compose + $lefts $last_right _.isub + _.istore_1) + update_$tuple ($_ _.compose + $tuple $last_right _.aaload (_.checkcast //type.tuple) + _.astore_0) + recur (: (-> Label (Bytecode Any)) + (function (_ @loop) + ($_ _.compose + update_$lefts + update_$tuple + (_.goto @loop)))) + + left_projection::method + (method.method ..modifier ..left_projection::name ..projection_type + (list) + (#.Some + (do _.monad + [@loop _.new_label + @recursive _.new_label + #let [::left ($_ _.compose + $lefts _.aaload)]] + ($_ _.compose + (_.set_label @loop) + $lefts $last_right (_.if_icmpge @recursive) + $tuple ::left + _.areturn + (_.set_label @recursive) + ## Recursive + (recur @loop))))) + + right_projection::method + (method.method ..modifier ..right_projection::name ..projection_type + (list) + (#.Some + (do _.monad + [@loop _.new_label + @not_tail _.new_label + @slice _.new_label + #let [$right ($_ _.compose + $lefts + _.iconst_1 + _.iadd) + $::nested ($_ _.compose + $tuple _.swap _.aaload) + super_nested ($_ _.compose + $tuple + $right + $tuple::size + (_.invokestatic (type.class "java.util.Arrays" (list)) "copyOfRange" + (type.method [(list //type.tuple //type.index //type.index) //type.tuple (list)])))]] + ($_ _.compose + (_.set_label @loop) + $last_right $right + _.dup2 (_.if_icmpne @not_tail) + ## _.pop + $::nested + _.areturn + (_.set_label @not_tail) + (_.if_icmpgt @slice) + ## Must recurse + (recur @loop) + (_.set_label @slice) + super_nested + _.areturn))))] + [left_projection::method + right_projection::method])) + +(def: #export apply::name "apply") + +(def: #export (apply::type arity) + (-> Arity (Type category.Method)) + (type.method [(list.repeat arity //type.value) //type.value (list)])) + +(def: #export apply + (_.invokevirtual //function.class ..apply::name (..apply::type 1))) + +(def: try::name "try") +(def: try::type (type.method [(list //function.class) //type.variant (list)])) +(def: #export try (..procedure ..try::name ..try::type)) + +(def: false _.iconst_0) +(def: true _.iconst_1) + +(def: try::method + (method.method ..modifier ..try::name ..try::type + (list) + (#.Some + (do _.monad + [@try _.new_label + @handler _.new_label + #let [$unsafe ..this + unit _.aconst_null + + ^StringWriter (type.class "java.io.StringWriter" (list)) + string_writer ($_ _.compose + (_.new ^StringWriter) + _.dup + (_.invokespecial ^StringWriter "<init>" (type.method [(list) type.void (list)]))) + + ^PrintWriter (type.class "java.io.PrintWriter" (list)) + print_writer ($_ _.compose + ## WTW + (_.new ^PrintWriter) ## WTWP + _.dup_x1 ## WTPWP + _.swap ## WTPPW + ..true ## WTPPWZ + (_.invokespecial ^PrintWriter "<init>" (type.method [(list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)])) + ## WTP + )]] + ($_ _.compose + (_.try @try @handler @handler //type.error) + (_.set_label @try) + $unsafe unit ..apply + ..right_injection _.areturn + (_.set_label @handler) ## T + string_writer ## TW + _.dup_x1 ## WTW + print_writer ## WTP + (_.invokevirtual //type.error "printStackTrace" (type.method [(list ^PrintWriter) type.void (list)])) ## W + (_.invokevirtual ^StringWriter "toString" (type.method [(list) //type.text (list)])) ## S + ..left_injection _.areturn + ))))) + +(def: reflection + (All [category] + (-> (Type (<| Return' Value' category)) Text)) + (|>> type.reflection reflection.reflection)) + +(def: ^Object (type.class "java.lang.Object" (list))) + +(def: generate_runtime + (Operation Any) + (let [class (..reflection ..class) + modifier (: (Modifier Class) + ($_ modifier\compose + class.public + class.final)) + bytecode (<| (format.run class.writer) + try.assume + (class.class jvm/version.v6_0 + modifier + (name.internal class) + (name.internal (..reflection ^Object)) (list) + (list) + (let [[left_projection::method right_projection::method] projection::method2] + (list ..decode_frac::method + ..variant::method + + ..pm_failure::method + + ..push::method + ..case::method + left_projection::method + right_projection::method + + ..try::method)) + (row.row)))] + (do ////.monad + [_ (generation.execute! [class bytecode])] + (generation.save! ..artifact_id [class bytecode])))) + +(def: generate_function + (Operation Any) + (let [apply::method+ (|> (enum.range n.enum + (inc //function/arity.minimum) + //function/arity.maximum) + (list\map (function (_ arity) + (method.method method.public ..apply::name (..apply::type arity) + (list) + (#.Some + (let [previous_inputs (|> arity + list.indices + (monad.map _.monad _.aload))] + ($_ _.compose + previous_inputs + (_.invokevirtual //function.class ..apply::name (..apply::type (dec arity))) + (_.checkcast //function.class) + (_.aload arity) + (_.invokevirtual //function.class ..apply::name (..apply::type //function/arity.minimum)) + _.areturn)))))) + (list& (method.method (modifier\compose method.public method.abstract) + ..apply::name (..apply::type //function/arity.minimum) + (list) + #.None))) + <init>::method (method.method method.public "<init>" //function.init + (list) + (#.Some + (let [$partials _.iload_1] + ($_ _.compose + ..this + (_.invokespecial ^Object "<init>" (type.method [(list) type.void (list)])) + ..this + $partials + (_.putfield //function.class //function/count.field //function/count.type) + _.return)))) + modifier (: (Modifier Class) + ($_ modifier\compose + class.public + class.abstract)) + class (..reflection //function.class) + partial_count (: (Resource Field) + (field.field (modifier\compose field.public field.final) + //function/count.field + //function/count.type + (row.row))) + bytecode (<| (format.run class.writer) + try.assume + (class.class jvm/version.v6_0 + modifier + (name.internal class) + (name.internal (..reflection ^Object)) (list) + (list partial_count) + (list& <init>::method apply::method+) + (row.row)))] + (do ////.monad + [_ (generation.execute! [class bytecode])] + (generation.save! //function.artifact_id [class bytecode])))) + +(def: #export generate + (Operation Any) + (do ////.monad + [_ ..generate_runtime] + ..generate_function)) + +(def: #export forge_label + (Operation Label) + (let [shift (n./ 4 i64.width)] + ## This shift is done to avoid the possibility of forged labels + ## to be in the range of the labels that are generated automatically + ## during the evaluation of Bytecode expressions. + (\ ////.monad map (i64.left_shift shift) generation.next))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux new file mode 100644 index 000000000..4ff9bdb81 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux @@ -0,0 +1,95 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [data + [number + ["." i32]] + [collection + ["." list]]] + [target + [jvm + ["_" bytecode (#+ Bytecode)] + ["." type] + [encoding + ["." signed]]]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." primitive] + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + [/// + ["." phase]]]]) + +(def: $Object + (type.class "java.lang.Object" (list))) + +(def: #export (tuple generate archive membersS) + (Generator (Tuple Synthesis)) + (case membersS + #.Nil + (\ phase.monad wrap //runtime.unit) + + (#.Cons singletonS #.Nil) + (generate archive singletonS) + + _ + (do {! phase.monad} + [membersI (|> membersS + list.enumeration + (monad.map ! (function (_ [idx member]) + (do ! + [memberI (generate archive member)] + (wrap (do _.monad + [_ _.dup + _ (_.int (.i64 idx)) + _ memberI] + _.aastore))))))] + (wrap (do {! _.monad} + [_ (_.int (.i64 (list.size membersS))) + _ (_.anewarray $Object)] + (monad.seq ! membersI)))))) + +(def: #export (tag lefts right?) + (-> Nat Bit (Bytecode Any)) + (case (if right? + (.inc lefts) + lefts) + 0 _.iconst-0 + 1 _.iconst-1 + 2 _.iconst-2 + 3 _.iconst-3 + 4 _.iconst-4 + 5 _.iconst-5 + tag (case (signed.s1 (.int tag)) + (#try.Success value) + (_.bipush value) + + (#try.Failure _) + (case (signed.s2 (.int tag)) + (#try.Success value) + (_.sipush value) + + (#try.Failure _) + (_.int (.i64 tag)))))) + +(def: #export (flag right?) + (-> Bit (Bytecode Any)) + (if right? + //runtime.right-flag + //runtime.left-flag)) + +(def: #export (variant generate archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (do phase.monad + [valueI (generate archive valueS)] + (wrap (do _.monad + [_ (..tag lefts right?) + _ (..flag right?) + _ valueI] + (_.invokestatic //runtime.class "variant" + (type.method [(list type.int $Object $Object) + (type.array $Object) + (list)])))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux new file mode 100644 index 000000000..4c6f14a3f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux @@ -0,0 +1,23 @@ +(.module: + [library + [lux #* + [target + [jvm + ["." type]]]]]) + +(def: #export frac (type.class "java.lang.Double" (list))) +(def: #export text (type.class "java.lang.String" (list))) + +(def: #export value (type.class "java.lang.Object" (list))) + +(def: #export tag type.int) +(def: #export flag ..value) +(def: #export variant (type.array ..value)) + +(def: #export offset type.int) +(def: #export index ..offset) +(def: #export tuple (type.array ..value)) + +(def: #export stack (type.array ..value)) + +(def: #export error (type.class "java.lang.Throwable" (list))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux new file mode 100644 index 000000000..ef82a6257 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux @@ -0,0 +1,49 @@ +(.module: + [library + [lux (#- Type type) + [target + [jvm + ["_" bytecode (#+ Bytecode)] + ["." type (#+ Type) ("#\." equivalence) + [category (#+ Primitive)] + ["." box]]]]]]) + +(def: #export field "value") + +(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>] + [(def: (<name> type) + (-> (Type Primitive) Text) + (`` (cond (~~ (template [<type> <output>] + [(type\= <type> type) <output>] + + [type.boolean <boolean>] + [type.byte <byte>] + [type.short <short>] + [type.int <int>] + [type.long <long>] + [type.float <float>] + [type.double <double>] + [type.char <char>])) + ## else + (undefined))))] + + [primitive-wrapper + box.boolean box.byte box.short box.int + box.long box.float box.double box.char] + [primitive-unwrap + "booleanValue" "byteValue" "shortValue" "intValue" + "longValue" "floatValue" "doubleValue" "charValue"] + ) + +(def: #export (wrap type) + (-> (Type Primitive) (Bytecode Any)) + (let [wrapper (type.class (primitive-wrapper type) (list))] + (_.invokestatic wrapper "valueOf" + (type.method [(list type) wrapper (list)])))) + +(def: #export (unwrap type) + (-> (Type Primitive) (Bytecode Any)) + (let [wrapper (type.class (primitive-wrapper type) (list))] + ($_ _.compose + (_.checkcast wrapper) + (_.invokevirtual wrapper (primitive-unwrap type) (type.method [(list) type (list)]))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua.lux new file mode 100644 index 000000000..529dd28a0 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua.lux @@ -0,0 +1,119 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." exception (#+ exception:)]] + [target + ["_" lua]]]] + ["." / #_ + [runtime (#+ Phase Phase!)] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." loop] + ["#." function] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + [analysis (#+)] + ["." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) + +(def: (statement expression archive synthesis) + Phase! + (case synthesis + (^template [<tag>] + [(^ (<tag> value)) + (//////phase\map _.return (expression archive synthesis))]) + ([synthesis.bit] + [synthesis.i64] + [synthesis.f64] + [synthesis.text] + [synthesis.variant] + [synthesis.tuple] + [#synthesis.Reference] + [synthesis.branch/get] + [synthesis.function/apply] + [#synthesis.Extension]) + + (^ (synthesis.branch/case case)) + (/case.case! statement expression archive case) + + (^ (synthesis.branch/let let)) + (/case.let! statement expression archive let) + + (^ (synthesis.branch/if if)) + (/case.if! statement expression archive if) + + (^ (synthesis.loop/scope scope)) + (do //////phase.monad + [[inits scope!] (/loop.scope! statement expression archive false scope)] + (wrap scope!)) + + (^ (synthesis.loop/recur updates)) + (/loop.recur! statement expression archive updates) + + (^ (synthesis.function/abstraction abstraction)) + (//////phase\map _.return (/function.function statement expression archive abstraction)) + )) + +(exception: #export cannot-recur-as-an-expression) + +(def: (expression archive synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + [(^ (<tag> value)) + (//////phase\wrap (<generator> value))]) + ([synthesis.bit /primitive.bit] + [synthesis.i64 /primitive.i64] + [synthesis.f64 /primitive.f64] + [synthesis.text /primitive.text]) + + (^ (synthesis.variant variantS)) + (/structure.variant expression archive variantS) + + (^ (synthesis.tuple members)) + (/structure.tuple expression archive members) + + (#synthesis.Reference value) + (//reference.reference /reference.system archive value) + + (^ (synthesis.branch/case case)) + (/case.case ..statement expression archive case) + + (^ (synthesis.branch/let let)) + (/case.let expression archive let) + + (^ (synthesis.branch/if if)) + (/case.if expression archive if) + + (^ (synthesis.branch/get get)) + (/case.get expression archive get) + + (^ (synthesis.loop/scope scope)) + (/loop.scope ..statement expression archive scope) + + (^ (synthesis.loop/recur updates)) + (//////phase.throw ..cannot-recur-as-an-expression []) + + (^ (synthesis.function/abstraction abstraction)) + (/function.function ..statement expression archive abstraction) + + (^ (synthesis.function/apply application)) + (/function.apply expression archive application) + + (#synthesis.Extension extension) + (///extension.apply archive expression extension))) + +(def: #export generate + Phase + ..expression) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/case.lux new file mode 100644 index 000000000..0be2698f8 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/case.lux @@ -0,0 +1,280 @@ +(.module: + [library + [lux (#- case let if) + [abstract + ["." monad (#+ do)]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set]]] + [target + ["_" lua (#+ Expression Var Statement)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Phase! Generator Generator!)] + ["#." reference] + ["#." primitive] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." synthesis #_ + ["#/." case]] + ["/#" // #_ + ["#." synthesis (#+ Member Synthesis Path)] + ["#." generation] + ["//#" /// #_ + [reference + ["#." variable (#+ Register)]] + ["#." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]]) + +(def: #export register + (-> Register Var) + (|>> (///reference.local //reference.system) :assume)) + +(def: #export capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: #export (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + ## TODO: Find some way to do 'let' without paying the price of the closure. + (wrap (|> bodyO + _.return + (_.closure (list (..register register))) + (_.apply/* (list valueO)))))) + +(def: #export (let! statement expression archive [valueS register bodyS]) + (Generator! [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (statement expression archive bodyS)] + (wrap ($_ _.then + (_.local/1 (..register register) valueO) + bodyO)))) + +(def: #export (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (wrap (list\fold (function (_ side source) + (.let [method (.case side + (^template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.int (.int lefts)))]) + ([#.Left //runtime.tuple//left] + [#.Right //runtime.tuple//right]))] + (method source))) + valueO + (list.reverse pathP))))) + +(def: #export (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (wrap (|> (_.if testO + (_.return thenO) + (_.return elseO)) + (_.closure (list)) + (_.apply/* (list)))))) + +(def: #export (if! statement expression archive [testS thenS elseS]) + (Generator! [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (statement expression archive thenS) + elseO (statement expression archive elseS)] + (wrap (_.if testO + thenO + elseO)))) + +(def: @savepoint (_.var "lux_pm_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) + +(def: (push! value) + (-> Expression Statement) + (_.statement (|> (_.var "table.insert") (_.apply/* (list @cursor value))))) + +(def: peek_and_pop + Expression + (|> (_.var "table.remove") (_.apply/* (list @cursor)))) + +(def: pop! + Statement + (_.statement ..peek_and_pop)) + +(def: peek + Expression + (_.nth (_.length @cursor) @cursor)) + +(def: save! + Statement + (_.statement (|> (_.var "table.insert") + (_.apply/* (list @savepoint + (_.apply/* (list @cursor + (_.int +1) + (_.length @cursor) + (_.int +1) + (_.table (list))) + (_.var "table.move"))))))) + +(def: restore! + Statement + (_.set (list @cursor) (|> (_.var "table.remove") (_.apply/* (list @savepoint))))) + +(def: fail! _.break) + +(template [<name> <flag> <prep>] + [(def: (<name> simple? idx) + (-> Bit Nat Statement) + ($_ _.then + (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) + (.if simple? + (_.when (_.= _.nil @temp) + fail!) + (_.if (_.= _.nil @temp) + fail! + (..push! @temp)))))] + + [left_choice _.nil (<|)] + [right_choice (_.string "") inc] + ) + +(def: (alternation pre! post!) + (-> Statement Statement Statement) + ($_ _.then + (_.while (_.bool true) + ($_ _.then + ..save! + pre!)) + ($_ _.then + ..restore! + post!))) + +(def: (pattern_matching' statement expression archive) + (-> Phase! Phase Archive Path (Operation Statement)) + (function (recur pathP) + (.case pathP + (#/////synthesis.Then bodyS) + (statement expression archive bodyS) + + #/////synthesis.Pop + (///////phase\wrap ..pop!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.local/1 (..register register) ..peek)) + + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail!))] + (wrap (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^template [<tag> <format>] + [(<tag> cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (do ! + [then! (recur then)] + (wrap [(_.= (|> match <format>) + ..peek) + then!]))) + (#.Cons cons))] + (wrap (_.cond clauses ..fail!)))]) + ([#/////synthesis.I64_Fork (<| _.int .int)] + [#/////synthesis.F64_Fork _.float] + [#/////synthesis.Text_Fork _.string]) + + (^template [<complex> <simple> <choice>] + [(^ (<complex> idx)) + (///////phase\wrap (<choice> false idx)) + + (^ (<simple> idx nextP)) + (///////phase\map (_.then (<choice> true idx)) (recur nextP))]) + ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] + [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (|> ..peek (_.nth (_.int +1)) ..push!)) + + (^template [<pm> <getter>] + [(^ (<pm> lefts)) + (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^ (/////synthesis.!bind_top register thenP)) + (do ///////phase.monad + [then! (recur thenP)] + (///////phase\wrap ($_ _.then + (_.local/1 (..register register) ..peek_and_pop) + then!))) + + (^template [<tag> <combinator>] + [(^ (<tag> preP postP)) + (do ///////phase.monad + [pre! (recur preP) + post! (recur postP)] + (wrap (<combinator> pre! post!)))]) + ([/////synthesis.path/seq _.then] + [/////synthesis.path/alt ..alternation])))) + +(def: (pattern_matching statement expression archive pathP) + (-> Phase! Phase Archive Path (Operation Statement)) + (do ///////phase.monad + [pattern_matching! (pattern_matching' statement expression archive pathP)] + (wrap ($_ _.then + (_.while (_.bool true) + pattern_matching!) + (_.statement (|> (_.var "error") (_.apply/* (list (_.string ////synthesis/case.pattern_matching_error))))))))) + +(def: #export dependencies + (-> Path (List Var)) + (|>> ////synthesis/case.storage + (get@ #////synthesis/case.dependencies) + set.to_list + (list\map (function (_ variable) + (.case variable + (#///////variable.Local register) + (..register register) + + (#///////variable.Foreign register) + (..capture register)))))) + +(def: #export (case! statement expression archive [valueS pathP]) + (Generator! [Synthesis Path]) + (do ///////phase.monad + [stack_init (expression archive valueS) + pattern_matching! (pattern_matching statement expression archive pathP)] + (wrap ($_ _.then + (_.local (list @temp)) + (_.local/1 @cursor (_.array (list stack_init))) + (_.local/1 @savepoint (_.array (list))) + pattern_matching!)))) + +(def: #export (case statement expression archive [valueS pathP]) + (-> Phase! (Generator [Synthesis Path])) + (|> [valueS pathP] + (..case! statement expression archive) + (\ ///////phase.monad map + (|>> (_.closure (list)) + (_.apply/* (list)))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux new file mode 100644 index 000000000..97a5b1691 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux @@ -0,0 +1,137 @@ +(.module: + [library + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + pipe] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [target + ["_" lua (#+ Var Expression Label Statement)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Phase! Generator)] + ["#." reference] + ["#." case] + ["/#" // #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant Tuple Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["#." generation (#+ Context)] + ["//#" /// #_ + [arity (#+ Arity)] + ["#." phase ("#\." monad)] + [reference + [variable (#+ Register Variable)]]]]]]) + +(def: #export (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do {! ///////phase.monad} + [functionO (expression archive functionS) + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply/* argsO+ functionO)))) + +(def: capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: (with_closure inits @self @args body!) + (-> (List Expression) Var (List Var) Statement [Statement Expression]) + (case inits + #.Nil + [(_.function @self @args body!) + @self] + + _ + (let [@inits (|> (list.enumeration inits) + (list\map (|>> product.left ..capture)))] + [(_.function @self @inits + ($_ _.then + (_.local_function @self @args body!) + (_.return @self))) + (_.apply/* inits @self)]))) + +(def: input + (|>> inc //case.register)) + +(def: (@scope function_name) + (-> Context Label) + (_.label (format (///reference.artifact function_name) "_scope"))) + +(def: #export (function statement expression archive [environment arity bodyS]) + (-> Phase! (Generator (Abstraction Synthesis))) + (do {! ///////phase.monad} + [[function_name body!] (/////generation.with_new_context archive + (do ! + [@scope (\ ! map ..@scope + (/////generation.context archive))] + (/////generation.with_anchor [1 @scope] + (statement expression archive bodyS)))) + closureO+ (monad.map ! (expression archive) environment) + #let [@curried (_.var "curried") + arityO (|> arity .int _.int) + @num_args (_.var "num_args") + @scope (..@scope function_name) + @self (_.var (///reference.artifact function_name)) + initialize_self! (_.local/1 (//case.register 0) @self) + initialize! (list\fold (.function (_ post pre!) + ($_ _.then + pre! + (_.local/1 (..input post) (_.nth (|> post inc .int _.int) @curried)))) + initialize_self! + (list.indices arity)) + pack (|>> (list) _.array) + unpack (_.apply/1 (_.var "table.unpack")) + @var_args (_.var "...")] + #let [[definition instantiation] (with_closure closureO+ @self (list @var_args) + ($_ _.then + (_.local/1 @curried (pack @var_args)) + (_.local/1 @num_args (_.length @curried)) + (_.cond (list [(|> @num_args (_.= arityO)) + ($_ _.then + initialize! + (_.set_label @scope) + body!)] + [(|> @num_args (_.> arityO)) + (let [arity_inputs (_.apply/5 (_.var "table.move") + @curried + (_.int +1) + arityO + (_.int +1) + (_.array (list))) + extra_inputs (_.apply/5 (_.var "table.move") + @curried + (_.+ (_.int +1) arityO) + @num_args + (_.int +1) + (_.array (list)))] + (_.return (|> @self + (_.apply/* (list (unpack arity_inputs))) + (_.apply/* (list (unpack extra_inputs))))))]) + ## (|> @num_args (_.< arityO)) + (_.return (_.closure (list @var_args) + (let [@extra_args (_.var "extra_args")] + ($_ _.then + (_.local/1 @extra_args (pack @var_args)) + (_.return (|> (_.array (list)) + (_.apply/5 (_.var "table.move") + @curried + (_.int +1) + @num_args + (_.int +1)) + (_.apply/5 (_.var "table.move") + @extra_args + (_.int +1) + (_.length @extra_args) + (_.+ (_.int +1) @num_args)) + unpack + (_.apply/1 @self)))))))) + ))] + _ (/////generation.execute! definition) + _ (/////generation.save! (product.right function_name) definition)] + (wrap instantiation))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux new file mode 100644 index 000000000..a6719856c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux @@ -0,0 +1,119 @@ +(.module: + [library + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)] + ["." set]]] + [math + [number + ["n" nat]]] + [target + ["_" lua (#+ Var Expression Label Statement)]]]] + ["." // #_ + [runtime (#+ Operation Phase Phase! Generator Generator!)] + ["#." case] + ["/#" // #_ + ["#." reference] + ["//#" /// #_ + ["."synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [meta + [archive (#+ Archive)]] + [reference + [variable (#+ Register)]]]]]]) + +(def: @scope + (-> Nat Label) + (|>> %.nat (format "scope") _.label)) + +(def: (setup initial? offset bindings as_expression? body) + (-> Bit Register (List Expression) Bit Statement Statement) + (let [variables (|> bindings + list.enumeration + (list\map (|>> product.left (n.+ offset) //case.register)))] + (if as_expression? + body + ($_ _.then + (if initial? + (_.let variables (_.multi bindings)) + (_.set variables (_.multi bindings))) + body)))) + +(def: #export (scope! statement expression archive as_expression? [start initsS+ bodyS]) + ## (Generator! (Scope Synthesis)) + (-> Phase! Phase Archive Bit (Scope Synthesis) + (Operation [(List Expression) Statement])) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (|> bodyS + (statement expression archive) + (\ ///////phase.monad map (|>> [(list)]))) + + ## true loop + _ + (do {! ///////phase.monad} + [@scope (\ ! map ..@scope /////generation.next) + initsO+ (monad.map ! (expression archive) initsS+) + body! (/////generation.with_anchor [start @scope] + (statement expression archive bodyS))] + (wrap [initsO+ + (..setup true start initsO+ as_expression? + ($_ _.then + (_.set_label @scope) + body!))])))) + +(def: #export (scope statement expression archive [start initsS+ bodyS]) + (-> Phase! (Generator (Scope Synthesis))) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [[[artifact_module artifact_id] [initsO+ scope!]] (/////generation.with_new_context archive + (scope! statement expression archive true [start initsS+ bodyS])) + #let [@loop (_.var (///reference.artifact [artifact_module artifact_id])) + locals (|> initsO+ + list.enumeration + (list\map (|>> product.left (n.+ start) //case.register))) + [directive instantiation] (: [Statement Expression] + (case (|> (synthesis.path/then bodyS) + //case.dependencies + (set.from_list _.hash) + (set.difference (set.from_list _.hash locals)) + set.to_list) + #.Nil + [(_.function @loop locals + scope!) + @loop] + + foreigns + (let [@context (_.var (format (_.code @loop) "_context"))] + [(_.function @context foreigns + ($_ _.then + (<| (_.local_function @loop locals) + scope!) + (_.return @loop) + )) + (|> @context (_.apply/* foreigns))])))] + _ (/////generation.execute! directive) + _ (/////generation.save! artifact_id directive)] + (wrap (|> instantiation (_.apply/* initsO+)))))) + +(def: #export (recur! statement expression archive argsS+) + (Generator! (List Synthesis)) + (do {! ///////phase.monad} + [[offset @scope] /////generation.anchor + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (..setup false offset argsO+ false (_.go_to @scope))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux new file mode 100644 index 000000000..7d010b4cb --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux @@ -0,0 +1,16 @@ +(.module: + [library + [lux (#- i64) + [target + ["_" lua (#+ Literal)]]]]) + +(template [<name> <type> <implementation>] + [(def: #export <name> + (-> <type> Literal) + <implementation>)] + + [bit Bit _.bool] + [i64 (I64 Any) (|>> .int _.int)] + [f64 Frac _.float] + [text Text _.string] + ) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux new file mode 100644 index 000000000..52bc69a29 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" lua (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System Expression) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux new file mode 100644 index 000000000..a0266db38 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux @@ -0,0 +1,432 @@ +(.module: + [library + [lux (#- Location inc) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<.>" code]]] + [data + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." list ("#\." functor)] + ["." row]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["." i64]]] + ["@" target + ["_" lua (#+ Expression Location Var Computation Literal Label Statement)]]]] + ["." /// #_ + ["#." reference] + ["//#" /// #_ + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// + ["#." phase] + [reference + [variable (#+ Register)]] + [meta + [archive (#+ Output Archive) + ["." artifact (#+ Registry)]]]]]]) + +(template [<name> <base>] + [(type: #export <name> + (<base> [Register Label] Expression Statement))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type: #export (Generator i) + (-> Phase Archive i (Operation Expression))) + +(type: #export Phase! + (-> Phase Archive Synthesis (Operation Statement))) + +(type: #export (Generator! i) + (-> Phase! Phase Archive i (Operation Statement))) + +(def: #export unit + (_.string /////synthesis.unit)) + +(def: (flag value) + (-> Bit Literal) + (if value + ..unit + _.nil)) + +(def: #export variant_tag_field "_lux_tag") +(def: #export variant_flag_field "_lux_flag") +(def: #export variant_value_field "_lux_value") + +(def: (variant' tag last? value) + (-> Expression Expression Expression Literal) + (_.table (list [..variant_tag_field tag] + [..variant_flag_field last?] + [..variant_value_field value]))) + +(def: #export (variant tag last? value) + (-> Nat Bit Expression Literal) + (variant' (_.int (.int tag)) + (flag last?) + value)) + +(def: #export none + Literal + (..variant 0 #0 ..unit)) + +(def: #export some + (-> Expression Literal) + (..variant 1 #1)) + +(def: #export left + (-> Expression Literal) + (..variant 0 #0)) + +(def: #export right + (-> Expression Literal) + (..variant 1 #1)) + +(def: (feature name definition) + (-> Var (-> Var Statement) Statement) + (definition name)) + +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} + body) + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(def: module_id + 0) + +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} + code) + (do meta.monad + [runtime_id meta.count] + (macro.with_gensyms [g!_] + (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.var (~ (code.text (%.code runtime)))))] + (case declaration + (#.Left name) + (macro.with_gensyms [g!_] + (let [g!name (code.local_identifier name)] + (wrap (list (` (def: #export (~ g!name) + Var + (~ runtime_name))) + + (` (def: (~ (code.local_identifier (format "@" name))) + Statement + (..feature (~ runtime_name) + (function ((~ g!_) (~ g!name)) + (_.set (~ g!name) (~ code)))))))))) + + (#.Right [name inputs]) + (macro.with_gensyms [g!_] + (let [g!name (code.local_identifier name) + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` _.Expression)) + inputs)] + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) + (-> (~+ inputs_typesC) Computation) + (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) + + (` (def: (~ (code.local_identifier (format "@" name))) + Statement + (..feature (~ runtime_name) + (function ((~ g!_) (~ g!_)) + (..with_vars [(~+ inputsC)] + (_.function (~ g!_) (list (~+ inputsC)) + (~ code)))))))))))))))) + +(def: (nth index table) + (-> Expression Expression Location) + (_.nth (_.+ (_.int +1) index) table)) + +(def: last_index + (|>> _.length (_.- (_.int +1)))) + +(with_expansions [<recur> (as_is ($_ _.then + (_.set (list lefts) (_.- last_index_right lefts)) + (_.set (list tuple) (..nth last_index_right tuple))))] + (runtime: (tuple//left lefts tuple) + (with_vars [last_index_right] + (<| (_.while (_.bool true)) + ($_ _.then + (_.local/1 last_index_right (..last_index tuple)) + (_.if (_.> lefts last_index_right) + ## No need for recursion + (_.return (..nth lefts tuple)) + ## Needs recursion + <recur>))))) + + (runtime: (tuple//right lefts tuple) + (with_vars [last_index_right right_index] + (<| (_.while (_.bool true)) + ($_ _.then + (_.local/1 last_index_right (..last_index tuple)) + (_.local/1 right_index (_.+ (_.int +1) lefts)) + (_.cond (list [(_.= last_index_right right_index) + (_.return (..nth right_index tuple))] + [(_.> last_index_right right_index) + ## Needs recursion. + <recur>]) + (_.return (_.apply/* (list tuple + (_.+ (_.int +1) right_index) + (_.length tuple) + (_.int +1) + (_.array (list))) + (_.var "table.move")))) + ))))) + +(runtime: (sum//get sum wants_last wanted_tag) + (let [no_match! (_.return _.nil) + sum_tag (_.the ..variant_tag_field sum) + sum_flag (_.the ..variant_flag_field sum) + sum_value (_.the ..variant_value_field sum) + is_last? (_.= ..unit sum_flag) + extact_match! (_.return sum_value) + test_recursion! (_.if is_last? + ## Must recurse. + ($_ _.then + (_.set (list wanted_tag) (_.- sum_tag wanted_tag)) + (_.set (list sum) sum_value)) + no_match!) + extrac_sub_variant! (_.return (variant' (_.- wanted_tag sum_tag) sum_flag sum_value))] + (<| (_.while (_.bool true)) + (_.cond (list [(_.= sum_tag wanted_tag) + (_.if (_.= wants_last sum_flag) + extact_match! + test_recursion!)] + [(_.< wanted_tag sum_tag) + test_recursion!] + [(_.= ..unit wants_last) + extrac_sub_variant!]) + no_match!)))) + +(def: runtime//adt + Statement + ($_ _.then + @tuple//left + @tuple//right + @sum//get + )) + +(runtime: (lux//try risky) + (with_vars [success value] + ($_ _.then + (_.let (list success value) (|> risky (_.apply/* (list ..unit)) + _.return (_.closure (list)) + list _.apply/* (|> (_.var "pcall")))) + (_.if success + (_.return (..right value)) + (_.return (..left value)))))) + +(runtime: (lux//program_args raw) + (with_vars [tail head idx] + ($_ _.then + (_.let (list tail) ..none) + (<| (_.for_step idx (_.length raw) (_.int +1) (_.int -1)) + (_.set (list tail) (..some (_.array (list (_.nth idx raw) + tail))))) + (_.return tail)))) + +(def: runtime//lux + Statement + ($_ _.then + @lux//try + @lux//program_args + )) + +(def: cap_shift + (_.% (_.int +64))) + +(runtime: (i64//left_shift param subject) + (_.return (_.bit_shl (..cap_shift param) subject))) + +(runtime: (i64//right_shift param subject) + (let [mask (|> (_.int +1) + (_.bit_shl (_.- param (_.int +64))) + (_.- (_.int +1)))] + ($_ _.then + (_.set (list param) (..cap_shift param)) + (_.return (|> subject + (_.bit_shr param) + (_.bit_and mask)))))) + +(runtime: (i64//division param subject) + (with_vars [floored] + ($_ _.then + (_.local/1 floored (_.// param subject)) + (let [potentially_floored? (_.< (_.int +0) floored) + inexact? (|> subject + (_.% param) + (_.= (_.int +0)) + _.not)] + (_.if (_.and potentially_floored? + inexact?) + (_.return (_.+ (_.int +1) floored)) + (_.return floored)))))) + +(runtime: (i64//remainder param subject) + (_.return (_.- (|> subject (..i64//division param) (_.* param)) + subject))) + +(def: runtime//i64 + Statement + ($_ _.then + @i64//left_shift + @i64//right_shift + @i64//division + @i64//remainder + )) + +(def: (find_byte_index subject param start) + (-> Expression Expression Expression Expression) + (_.apply/4 (_.var "string.find") subject param start (_.bool #1))) + +(def: (char_index subject byte_index) + (-> Expression Expression Expression) + (|> byte_index + (_.apply/3 (_.var "utf8.len") subject (_.int +1)))) + +(def: (byte_index subject char_index) + (-> Expression Expression Expression) + (|> char_index + (_.+ (_.int +1)) + (_.apply/2 (_.var "utf8.offset") subject))) + +(def: lux_index + (-> Expression Expression) + (_.- (_.int +1))) + +## TODO: Remove this once the Lua compiler becomes self-hosted. +(def: on_rembulan? + (_.= (_.string "Lua 5.3") + (_.var "_VERSION"))) + +(runtime: (text//index subject param start) + (with_expansions [<rembulan> ($_ _.then + (_.local/1 byte_index (|> start + (_.+ (_.int +1)) + (..find_byte_index subject param))) + (_.if (_.= _.nil byte_index) + (_.return ..none) + (_.return (..some (..lux_index byte_index))))) + <normal> ($_ _.then + (_.local/1 byte_index (|> start + (..byte_index subject) + (..find_byte_index subject param))) + (_.if (_.= _.nil byte_index) + (_.return ..none) + (_.return (..some (|> byte_index + (..char_index subject) + ..lux_index)))))] + (with_vars [byte_index] + (for {@.lua <normal>} + (_.if ..on_rembulan? + <rembulan> + <normal>))))) + +(runtime: (text//clip text offset length) + (with_expansions [<rembulan> (_.return (_.apply/3 (_.var "string.sub") text (_.+ (_.int +1) offset) (_.+ offset length))) + <normal> (_.return (_.apply/3 (_.var "string.sub") + text + (..byte_index text offset) + (|> (_.+ offset length) + ## (_.+ (_.int +1)) + (..byte_index text) + (_.- (_.int +1)))))] + (for {@.lua <normal>} + (_.if ..on_rembulan? + <rembulan> + <normal>)))) + +(runtime: (text//size subject) + (with_expansions [<rembulan> (_.return (_.apply/1 (_.var "string.len") subject)) + <normal> (_.return (_.apply/1 (_.var "utf8.len") subject))] + (for {@.lua <normal>} + (_.if ..on_rembulan? + <rembulan> + <normal>)))) + +(runtime: (text//char idx text) + (with_expansions [<rembulan> (with_vars [char] + ($_ _.then + (_.local/1 char (_.apply/* (list text idx) + (_.var "string.byte"))) + (_.if (_.= _.nil char) + (_.statement (_.error/1 (_.string "[Lux Error] Cannot get char from text."))) + (_.return char)))) + <normal> (with_vars [offset char] + ($_ _.then + (_.local/1 offset (_.apply/2 (_.var "utf8.offset") text idx)) + (_.if (_.= _.nil offset) + (_.statement (_.error/1 (_.string "[Lux Error] Cannot get char from text."))) + (_.return (_.apply/2 (_.var "utf8.codepoint") text offset)))))] + (for {@.lua <normal>} + (_.if ..on_rembulan? + <rembulan> + <normal>)))) + +(def: runtime//text + Statement + ($_ _.then + @text//index + @text//clip + @text//size + @text//char + )) + +(runtime: (array//write idx value array) + ($_ _.then + (_.set (list (..nth idx array)) value) + (_.return array))) + +(def: runtime//array + Statement + ($_ _.then + @array//write + )) + +(def: runtime + Statement + ($_ _.then + ..runtime//adt + ..runtime//lux + ..runtime//i64 + ..runtime//text + ..runtime//array + )) + +(def: #export generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! ..module_id ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row [..module_id + (|> ..runtime + _.code + (\ utf8.codec encode))])]))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux new file mode 100644 index 000000000..ff9bae4be --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux @@ -0,0 +1,37 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [target + ["_" lua (#+ Expression)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." primitive] + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + ["//#" /// #_ + ["#." phase ("#\." monad)]]]]) + +(def: #export (tuple generate archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + #.Nil + (///////phase\wrap (//primitive.text /////synthesis.unit)) + + (#.Cons singletonS #.Nil) + (generate archive singletonS) + + _ + (|> elemsS+ + (monad.map ///////phase.monad (generate archive)) + (///////phase\map _.array)))) + +(def: #export (variant generate archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (inc lefts) + lefts)] + (///////phase\map (//runtime.variant tag right?) + (generate archive valueS)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php.lux new file mode 100644 index 000000000..5bcb2770d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php.lux @@ -0,0 +1,103 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." exception (#+ exception:)]] + [target + ["_" php]]]] + ["." / #_ + [runtime (#+ Phase Phase!)] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." loop] + ["#." function] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + [analysis (#+)] + ["#." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) + +(def: (statement expression archive synthesis) + Phase! + (case synthesis + (^template [<tag>] + [(^ (<tag> value)) + (//////phase\map _.return (expression archive synthesis))]) + ([////synthesis.bit] + [////synthesis.i64] + [////synthesis.f64] + [////synthesis.text] + [////synthesis.variant] + [////synthesis.tuple] + [#////synthesis.Reference] + [////synthesis.branch/get] + [////synthesis.function/apply] + [#////synthesis.Extension]) + + (^ (////synthesis.branch/case case)) + (/case.case! statement expression archive case) + + (^template [<tag> <generator>] + [(^ (<tag> value)) + (<generator> statement expression archive value)]) + ([////synthesis.branch/let /case.let!] + [////synthesis.branch/if /case.if!] + [////synthesis.loop/scope /loop.scope!] + [////synthesis.loop/recur /loop.recur!]) + + (^ (////synthesis.function/abstraction abstraction)) + (//////phase\map _.return (/function.function statement expression archive abstraction)) + )) + +(exception: #export cannot-recur-as-an-expression) + +(def: #export (expression archive synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + [(^ (<tag> value)) + (//////phase\wrap (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + (#////synthesis.Reference value) + (//reference.reference /reference.system archive value) + + (^template [<tag> <generator>] + [(^ (<tag> value)) + (<generator> expression archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + [////synthesis.function/apply /function.apply]) + + (^template [<tag> <generator>] + [(^ (<tag> value)) + (<generator> statement expression archive value)]) + ([////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.function/abstraction /function.function]) + + (^ (////synthesis.loop/recur _)) + (//////phase.throw ..cannot-recur-as-an-expression []) + + (#////synthesis.Extension extension) + (///extension.apply archive expression extension))) + +(def: #export generate + Phase + ..expression) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/case.lux new file mode 100644 index 000000000..d6a4c67b0 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/case.lux @@ -0,0 +1,298 @@ +(.module: + [library + [lux (#- case let if) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set]]] + [math + [number + ["i" int]]] + [target + ["_" php (#+ Expression Var Statement)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Phase! Generator Generator!)] + ["#." reference] + ["#." primitive] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." synthesis #_ + ["#/." case]] + ["/#" // #_ + ["#." synthesis (#+ Member Synthesis Path)] + ["#." generation] + ["//#" /// #_ + [reference + ["#." variable (#+ Register)]] + ["#." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]]) + +(def: #export register + (-> Register Var) + (|>> (///reference.local //reference.system) :assume)) + +(def: #export capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: #export (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueG (expression archive valueS) + bodyG (expression archive bodyS)] + (wrap (|> bodyG + (list (_.set (..register register) valueG)) + _.array/* + (_.nth (_.int +1)))))) + +(def: #export (let! statement expression archive [valueS register bodyS]) + (Generator! [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + body! (statement expression archive bodyS)] + (wrap ($_ _.then + (_.set! (..register register) valueO) + body!)))) + +(def: #export (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testG (expression archive testS) + thenG (expression archive thenS) + elseG (expression archive elseS)] + (wrap (_.? testG thenG elseG)))) + +(def: #export (if! statement expression archive [testS thenS elseS]) + (Generator! [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [test! (expression archive testS) + then! (statement expression archive thenS) + else! (statement expression archive elseS)] + (wrap (_.if test! + then! + else!)))) + +(def: #export (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueG (expression archive valueS)] + (wrap (list\fold (function (_ side source) + (.let [method (.case side + (^template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.int (.int lefts)))]) + ([#.Left //runtime.tuple//left] + [#.Right //runtime.tuple//right]))] + (method source))) + valueG + (list.reverse pathP))))) + +(def: @savepoint (_.var "lux_pm_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) + +(def: (push! value) + (-> Expression Statement) + (_.; (_.array_push/2 [@cursor value]))) + +(def: peek_and_pop + Expression + (_.array_pop/1 @cursor)) + +(def: pop! + Statement + (_.; ..peek_and_pop)) + +(def: peek + Expression + (_.nth (|> @cursor _.count/1 (_.- (_.int +1))) + @cursor)) + +(def: save! + Statement + (.let [cursor (_.array_slice/2 [@cursor (_.int +0)])] + (_.; (_.array_push/2 [@savepoint cursor])))) + +(def: restore! + Statement + (_.set! @cursor (_.array_pop/1 @savepoint))) + +(def: fail! _.break) + +(def: (multi_pop! pops) + (-> Nat Statement) + (_.; (_.array_splice/3 [@cursor + (_.int +0) + (_.int (i.* -1 (.int pops)))]))) + +(template [<name> <flag> <prep>] + [(def: (<name> simple? idx) + (-> Bit Nat Statement) + ($_ _.then + (_.set! @temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) + (.if simple? + (_.when (_.is_null/1 @temp) + fail!) + (_.if (_.is_null/1 @temp) + fail! + (..push! @temp)))))] + + [left_choice _.null (<|)] + [right_choice (_.string "") inc] + ) + +(def: (alternation pre! post!) + (-> Statement Statement Statement) + ($_ _.then + (_.do_while (_.bool false) + ($_ _.then + ..save! + pre!)) + ($_ _.then + ..restore! + post!))) + +(def: (pattern_matching' statement expression archive) + (Generator! Path) + (function (recur pathP) + (.case pathP + (#/////synthesis.Then bodyS) + (statement expression archive bodyS) + + #/////synthesis.Pop + (///////phase\wrap ..pop!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.set! (..register register) ..peek)) + + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail!))] + (wrap (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^template [<tag> <format>] + [(<tag> cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (do ! + [then! (recur then)] + (wrap [(_.=== (|> match <format>) + ..peek) + then!]))) + (#.Cons cons))] + (wrap (_.cond clauses ..fail!)))]) + ([#/////synthesis.I64_Fork //primitive.i64] + [#/////synthesis.F64_Fork //primitive.f64] + [#/////synthesis.Text_Fork //primitive.text]) + + (^template [<complex> <simple> <choice>] + [(^ (<complex> idx)) + (///////phase\wrap (<choice> false idx)) + + (^ (<simple> idx nextP)) + (|> nextP + recur + (\ ///////phase.monad map (_.then (<choice> true idx))))]) + ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] + [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!)) + + (^template [<pm> <getter>] + [(^ (<pm> lefts)) + (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^ (/////synthesis.!bind_top register thenP)) + (do ///////phase.monad + [then! (recur thenP)] + (///////phase\wrap ($_ _.then + (_.set! (..register register) ..peek_and_pop) + then!))) + + ## (^ (/////synthesis.!multi_pop nextP)) + ## (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)] + ## (do ///////phase.monad + ## [next! (recur nextP')] + ## (///////phase\wrap ($_ _.then + ## (..multi_pop! (n.+ 2 extra_pops)) + ## next!)))) + + (^template [<tag> <combinator>] + [(^ (<tag> preP postP)) + (do ///////phase.monad + [pre! (recur preP) + post! (recur postP)] + (wrap (<combinator> pre! post!)))]) + ([/////synthesis.path/seq _.then] + [/////synthesis.path/alt ..alternation])))) + +(def: (pattern_matching statement expression archive pathP) + (Generator! Path) + (do ///////phase.monad + [iteration! (pattern_matching' statement expression archive pathP)] + (wrap ($_ _.then + (_.do_while (_.bool false) + iteration!) + (_.throw (_.new (_.constant "Exception") (list (_.string ////synthesis/case.pattern_matching_error)))))))) + +(def: (gensym prefix) + (-> Text (Operation Text)) + (\ ///////phase.monad map (|>> %.nat (format prefix)) /////generation.next)) + +(def: #export dependencies + (-> Path (List Var)) + (|>> ////synthesis/case.storage + (get@ #////synthesis/case.dependencies) + set.to_list + (list\map (function (_ variable) + (.case variable + (#///////variable.Local register) + (..register register) + + (#///////variable.Foreign register) + (..capture register)))))) + +(def: #export (case! statement expression archive [valueS pathP]) + (Generator! [Synthesis Path]) + (do ///////phase.monad + [stack_init (expression archive valueS) + pattern_matching! (pattern_matching statement expression archive pathP)] + (wrap ($_ _.then + (_.set! @cursor (_.array/* (list stack_init))) + (_.set! @savepoint (_.array/* (list))) + pattern_matching!)))) + +(def: #export (case statement expression archive [valueS pathP]) + (-> Phase! (Generator [Synthesis Path])) + (do {! ///////phase.monad} + [[[case_module case_artifact] case!] (/////generation.with_new_context archive + (case! statement expression archive [valueS pathP])) + #let [@case (_.constant (///reference.artifact [case_module case_artifact])) + @dependencies+ (..dependencies (/////synthesis.path/seq (/////synthesis.path/then valueS) + pathP)) + directive (_.define_function @case (list\map _.parameter @dependencies+) case!)] + _ (/////generation.execute! directive) + _ (/////generation.save! case_artifact directive)] + (wrap (_.apply/* @dependencies+ @case)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension.lux new file mode 100644 index 000000000..1880d7700 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension.lux @@ -0,0 +1,14 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common]]) + +(def: #export bundle + Bundle + common.bundle) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux new file mode 100644 index 000000000..5eaccf0aa --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux @@ -0,0 +1,112 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function]] + [data + ["." product] + ["." text] + [number + ["f" frac]] + [collection + ["." dictionary]]] + [target + ["_" php (#+ Expression)]]]] + ["." /// #_ + ["#." runtime (#+ Operation Phase Handler Bundle)] + ["#." primitive] + [// + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + [// + [extension + ["." bundle]]]]]) + +(def: lux-procs + Bundle + (|> bundle.empty + (bundle.install "is" (binary (product.uncurry _.=))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(def: i64-procs + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary (product.uncurry _.bit-and))) + (bundle.install "or" (binary (product.uncurry _.bit-or))) + (bundle.install "xor" (binary (product.uncurry _.bit-xor))) + (bundle.install "left-shift" (binary (product.uncurry _.bit-shl))) + (bundle.install "logical-right-shift" (binary (product.uncurry ///runtime.i64//logic-right-shift))) + (bundle.install "arithmetic-right-shift" (binary (product.uncurry _.bit-shr))) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + ))) + +(def: int-procs + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.%))) + (bundle.install "frac" (unary _.floatval/1)) + (bundle.install "char" (unary _.chr/1))))) + +(def: frac-procs + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.%))) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "int" (unary _.intval/1)) + (bundle.install "encode" (unary _.strval/1)) + (bundle.install "decode" (unary (|>> _.floatval/1 ///runtime.some))) + ))) + +(def: (text//index [startO partO textO]) + (Trinary (Expression Any)) + (///runtime.text//index textO partO startO)) + +(def: text-procs + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "concat" (binary (product.uncurry _.concat))) + (bundle.install "index" (trinary text//index)) + (bundle.install "size" (unary _.strlen/1)) + (bundle.install "char" (binary (function (text//char [text idx]) + (|> text (_.nth idx) _.ord/1)))) + (bundle.install "clip" (trinary (function (text//clip [from to text]) + (_.substr/3 [text from (_.- from to)])))) + ))) + +(def: io-procs + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary (|>> (_.concat (_.string text.new-line)) _.print/1))) + (bundle.install "error" (unary ///runtime.io//throw!)) + (bundle.install "exit" (unary _.exit/1)) + (bundle.install "current-time" (nullary (|>> _.time/0 (_.* (_.int +1,000)))))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> lux-procs + (dictionary.merge i64-procs) + (dictionary.merge int-procs) + (dictionary.merge frac-procs) + (dictionary.merge text-procs) + (dictionary.merge io-procs) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/function.lux new file mode 100644 index 000000000..819f6b244 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/function.lux @@ -0,0 +1,116 @@ +(.module: + [library + [lux (#- Global function) + [abstract + ["." monad (#+ do)]] + [control + pipe] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [target + ["_" php (#+ Var Global Expression Argument Label Statement)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Phase! Generator)] + ["#." reference] + ["#." case] + ["/#" // #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant Tuple Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["#." generation (#+ Context)] + ["//#" /// #_ + [arity (#+ Arity)] + ["#." phase ("#\." monad)] + [reference + [variable (#+ Register Variable)]]]]]]) + +(def: #export (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do {! ///////phase.monad} + [functionG (expression archive functionS) + argsG+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply/*' argsG+ functionG)))) + +(def: capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: input + (|>> inc //case.register)) + +(def: (@scope function_name) + (-> Context Label) + (_.label (format (///reference.artifact function_name) "_scope"))) + +(def: (with_closure inits @selfG @selfL body!) + (-> (List Expression) Global Var Statement [Statement Expression]) + (case inits + #.Nil + [($_ _.then + (_.set! @selfL (_.closure (list (_.reference @selfL)) (list) body!)) + (_.set! @selfG @selfL)) + @selfG] + + _ + (let [@inits (|> (list.enumeration inits) + (list\map (|>> product.left ..capture)))] + [(_.set! @selfG (_.closure (list) (list\map _.parameter @inits) + ($_ _.then + (_.set! @selfL (_.closure (list& (_.reference @selfL) (list\map _.reference @inits)) + (list) + body!)) + (_.return @selfL)))) + (_.apply/* inits @selfG)]))) + +(def: #export (function statement expression archive [environment arity bodyS]) + (-> Phase! (Generator (Abstraction Synthesis))) + (do {! ///////phase.monad} + [[function_name body!] (/////generation.with_new_context archive + (do ! + [@scope (\ ! map ..@scope + (/////generation.context archive))] + (/////generation.with_anchor [1 @scope] + (statement expression archive bodyS)))) + closureG+ (monad.map ! (expression archive) environment) + #let [@curried (_.var "curried") + arityG (|> arity .int _.int) + @num_args (_.var "num_args") + @scope (..@scope function_name) + @selfG (_.global (///reference.artifact function_name)) + @selfL (_.var (///reference.artifact function_name)) + initialize_self! (_.set! (//case.register 0) @selfL) + initialize! (list\fold (.function (_ post pre!) + ($_ _.then + pre! + (_.set! (..input post) (_.nth (|> post .int _.int) @curried)))) + initialize_self! + (list.indices arity))] + #let [[definition instantiation] (..with_closure closureG+ @selfG @selfL + ($_ _.then + (_.set! @num_args (_.func_num_args/0 [])) + (_.set! @curried (_.func_get_args/0 [])) + (_.cond (list [(|> @num_args (_.=== arityG)) + ($_ _.then + initialize! + (_.set_label @scope) + body!)] + [(|> @num_args (_.> arityG)) + (let [arity_inputs (_.array_slice/3 [@curried (_.int +0) arityG]) + extra_inputs (_.array_slice/2 [@curried arityG]) + next (_.call_user_func_array/2 [@selfL arity_inputs])] + (_.return (_.call_user_func_array/2 [next extra_inputs])))]) + ## (|> @num_args (_.< arityG)) + (let [@missing (_.var "missing")] + (_.return (<| (_.closure (list (_.reference @selfL) (_.reference @curried)) (list)) + ($_ _.then + (_.set! @missing (_.func_get_args/0 [])) + (_.return (_.call_user_func_array/2 [@selfL (_.array_merge/+ @curried (list @missing))]))))))) + ))] + _ (/////generation.execute! definition) + _ (/////generation.save! (product.right function_name) definition)] + (wrap instantiation))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/loop.lux new file mode 100644 index 000000000..9dc7e9e78 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/loop.lux @@ -0,0 +1,122 @@ +(.module: + [library + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set (#+ Set)]]] + [math + [number + ["n" nat]]] + [target + ["_" php (#+ Var Expression Label Statement)]]]] + ["." // #_ + [runtime (#+ Operation Phase Phase! Generator Generator!)] + ["#." case] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + [synthesis + ["." case]] + ["/#" // #_ + ["."synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [meta + [archive (#+ Archive)]] + [reference + [variable (#+ Register)]]]]]]]) + +(def: @scope + (-> Nat Label) + (|>> %.nat (format "scope") _.label)) + +(def: (setup offset bindings body) + (-> Register (List Expression) Statement Statement) + (|> bindings + list.enumeration + (list\map (function (_ [register value]) + (let [variable (//case.register (n.+ offset register))] + (_.set! variable value)))) + list.reverse + (list\fold _.then body))) + +(def: #export (scope! statement expression archive [start initsS+ bodyS]) + (Generator! (Scope Synthesis)) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (statement expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [@scope (\ ! map ..@scope /////generation.next) + initsO+ (monad.map ! (expression archive) initsS+) + body! (/////generation.with_anchor [start @scope] + (statement expression archive bodyS))] + (wrap (..setup start initsO+ + ($_ _.then + (_.set_label @scope) + body!)))))) + +(def: #export (scope statement expression archive [start initsS+ bodyS]) + (-> Phase! (Generator (Scope Synthesis))) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [[[loop_module loop_artifact] scope!] (/////generation.with_new_context archive + (..scope! statement expression archive [start initsS+ bodyS])) + #let [locals (|> initsS+ + list.enumeration + (list\map (|>> product.left (n.+ start) //case.register _.parameter))) + @loop (_.constant (///reference.artifact [loop_module loop_artifact])) + loop_variables (set.from_list _.hash (list\map product.right locals)) + referenced_variables (: (-> Synthesis (Set Var)) + (|>> synthesis.path/then + //case.dependencies + (set.from_list _.hash))) + [directive instantiation] (: [Statement Expression] + (case (|> (list\map referenced_variables initsS+) + (list\fold set.union (referenced_variables bodyS)) + (set.difference loop_variables) + set.to_list) + #.Nil + [(_.define_function @loop (list) scope!) + @loop] + + foreigns + [(<| (_.define_function @loop (list\map _.parameter foreigns)) + (_.return (_.closure (list\map _.parameter foreigns) (list) scope!))) + (_.apply/* foreigns @loop)]))] + _ (/////generation.execute! directive) + _ (/////generation.save! loop_artifact directive)] + (wrap (_.apply/* (list) instantiation))))) + +(def: @temp + (_.var "lux_recur_values")) + +(def: #export (recur! statement expression archive argsS+) + (Generator! (List Synthesis)) + (do {! ///////phase.monad} + [[offset @scope] /////generation.anchor + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap ($_ _.then + (_.set! @temp (_.array/* argsO+)) + (..setup offset + (|> argsO+ + list.enumeration + (list\map (function (_ [idx _]) + (_.nth (_.int (.int idx)) @temp)))) + (_.go_to @scope)))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux new file mode 100644 index 000000000..9101ee48d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux @@ -0,0 +1,32 @@ +(.module: + [library + [lux (#- i64) + [control + [pipe (#+ cond> new>)]] + [math + [number + ["." frac]]] + [target + ["_" php (#+ Literal Expression)]]]] + ["." // #_ + ["#." runtime]]) + +(def: #export bit + (-> Bit Literal) + _.bool) + +(def: #export (i64 value) + (-> (I64 Any) Expression) + (let [h32 (|> value //runtime.high .int _.int) + l32 (|> value //runtime.low .int _.int)] + (|> h32 + (_.bit_shl (_.int +32)) + (_.bit_or l32)))) + +(def: #export f64 + (-> Frac Literal) + _.float) + +(def: #export text + (-> Text Literal) + _.string) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/reference.lux new file mode 100644 index 000000000..5dce15a26 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" php (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System Expression) + + (def: constant _.global) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux new file mode 100644 index 000000000..231bb4a29 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux @@ -0,0 +1,610 @@ +(.module: + [library + [lux (#- Location inc) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<.>" code]]] + [data + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." list ("#\." functor)] + ["." row]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["." i64]]] + ["@" target + ["_" php (#+ Expression Label Constant Var Computation Literal Statement)]]]] + ["." /// #_ + ["#." reference] + ["//#" /// #_ + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// + ["#." phase] + [reference + [variable (#+ Register)]] + [meta + [archive (#+ Output Archive) + ["." artifact (#+ Registry)]]]]]]) + +(template [<name> <base>] + [(type: #export <name> + (<base> [Nat Label] Expression Statement))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type: #export (Generator i) + (-> Phase Archive i (Operation Expression))) + +(type: #export Phase! + (-> Phase Archive Synthesis (Operation Statement))) + +(type: #export (Generator! i) + (-> Phase! Phase Archive i (Operation Statement))) + +(def: #export unit + (_.string /////synthesis.unit)) + +(def: (flag value) + (-> Bit Literal) + (if value + ..unit + _.null)) + +(def: (feature name definition) + (-> Constant (-> Constant Statement) Statement) + (definition name)) + +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} + body) + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(def: module_id + 0) + +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} + code) + (do meta.monad + [runtime_id meta.count] + (macro.with_gensyms [g!_] + (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.constant (~ (code.text (%.code runtime)))))] + (case declaration + (#.Left name) + (macro.with_gensyms [g!_] + (let [g!name (code.local_identifier name)] + (wrap (list (` (def: #export (~ g!name) + Var + (~ runtime_name))) + + (` (def: (~ (code.local_identifier (format "@" name))) + Statement + (..feature (~ runtime_name) + (function ((~ g!_) (~ g!name)) + (_.define (~ g!name) (~ code)))))))))) + + (#.Right [name inputs]) + (macro.with_gensyms [g!_] + (let [g!name (code.local_identifier name) + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` _.Expression)) + inputs)] + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) + (-> (~+ inputs_typesC) Computation) + (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) + + (` (def: (~ (code.local_identifier (format "@" name))) + Statement + (..feature (~ runtime_name) + (function ((~ g!_) (~ g!_)) + (..with_vars [(~+ inputsC)] + (_.define_function (~ g!_) + (list (~+ (list\map (|>> (~) [false] (`)) inputsC))) + (~ code)))))))))))))))) + +(runtime: (io//log! message) + ($_ _.then + (_.echo message) + (_.echo (_.string text.new_line)) + (_.return ..unit))) + +(runtime: (io//throw! message) + ($_ _.then + (_.throw (_.new (_.constant "Exception") (list message))) + (_.return ..unit))) + +(def: runtime//io + Statement + ($_ _.then + @io//log! + @io//throw! + )) + +(def: #export tuple_size_field + "_lux_size") + +(def: tuple_size + (_.nth (_.string ..tuple_size_field))) + +(def: jphp? + (_.=== (_.string "5.6.99") (_.phpversion/0 []))) + +(runtime: (array//length array) + ## TODO: Get rid of this as soon as JPHP is no longer necessary. + (_.if ..jphp? + (_.return (..tuple_size array)) + (_.return (_.count/1 array)))) + +(runtime: (array//write idx value array) + ($_ _.then + (_.set! (_.nth idx array) value) + (_.return array))) + +(def: runtime//array + Statement + ($_ _.then + @array//length + @array//write + )) + +(def: jphp_last_index + (|>> ..tuple_size (_.- (_.int +1)))) + +(def: normal_last_index + (|>> _.count/1 (_.- (_.int +1)))) + +(with_expansions [<recur> (as_is ($_ _.then + (_.set! lefts (_.- last_index_right lefts)) + (_.set! tuple (_.nth last_index_right tuple))))] + (runtime: (tuple//make size values) + (_.if ..jphp? + ($_ _.then + (_.set! (..tuple_size values) size) + (_.return values)) + ## https://www.php.net/manual/en/language.operators.assignment.php + ## https://www.php.net/manual/en/language.references.php + ## https://www.php.net/manual/en/functions.arguments.php + ## https://www.php.net/manual/en/language.oop5.references.php + ## https://www.php.net/manual/en/class.arrayobject.php + (_.return (_.new (_.constant "ArrayObject") (list values))))) + + (runtime: (tuple//left lefts tuple) + (with_vars [last_index_right] + (<| (_.while (_.bool true)) + ($_ _.then + (_.if ..jphp? + (_.set! last_index_right (..jphp_last_index tuple)) + (_.set! last_index_right (..normal_last_index tuple))) + (_.if (_.> lefts last_index_right) + ## No need for recursion + (_.return (_.nth lefts tuple)) + ## Needs recursion + <recur>))))) + + ## TODO: Get rid of this as soon as JPHP is no longer necessary. + (runtime: (tuple//slice offset input) + (with_vars [size index output] + ($_ _.then + (_.set! size (..array//length input)) + (_.set! index (_.int +0)) + (_.set! output (_.array/* (list))) + (<| (_.while (|> index (_.+ offset) (_.< size))) + ($_ _.then + (_.set! (_.nth index output) (_.nth (_.+ offset index) input)) + (_.set! index (_.+ (_.int +1) index)) + )) + (_.return (..tuple//make (_.- offset size) output)) + ))) + + (runtime: (tuple//right lefts tuple) + (with_vars [last_index_right right_index] + (<| (_.while (_.bool true)) + ($_ _.then + (_.if ..jphp? + (_.set! last_index_right (..jphp_last_index tuple)) + (_.set! last_index_right (..normal_last_index tuple))) + (_.set! right_index (_.+ (_.int +1) lefts)) + (_.cond (list [(_.=== last_index_right right_index) + (_.return (_.nth right_index tuple))] + [(_.> last_index_right right_index) + ## Needs recursion. + <recur>]) + (_.if ..jphp? + (_.return (..tuple//make (_.- right_index (..tuple_size tuple)) + (..tuple//slice right_index tuple))) + (_.return (..tuple//make (_.- right_index (_.count/1 tuple)) + (_.array_slice/2 [(_.do "getArrayCopy" (list) tuple) right_index]))))) + ))))) + +(def: #export variant_tag_field "_lux_tag") +(def: #export variant_flag_field "_lux_flag") +(def: #export variant_value_field "_lux_value") + +(runtime: (sum//make tag last? value) + (_.return (_.array/** (list [(_.string ..variant_tag_field) tag] + [(_.string ..variant_flag_field) last?] + [(_.string ..variant_value_field) value])))) + +(def: #export (variant tag last? value) + (-> Nat Bit Expression Computation) + (sum//make (_.int (.int tag)) + (..flag last?) + value)) + +(def: #export none + Computation + (..variant 0 #0 ..unit)) + +(def: #export some + (-> Expression Computation) + (..variant 1 #1)) + +(def: #export left + (-> Expression Computation) + (..variant 0 #0)) + +(def: #export right + (-> Expression Computation) + (..variant 1 #1)) + +(runtime: (sum//get sum wantsLast wantedTag) + (let [no_match! (_.return _.null) + sum_tag (_.nth (_.string ..variant_tag_field) sum) + ## sum_tag (_.nth (_.int +0) sum) + sum_flag (_.nth (_.string ..variant_flag_field) sum) + ## sum_flag (_.nth (_.int +1) sum) + sum_value (_.nth (_.string ..variant_value_field) sum) + ## sum_value (_.nth (_.int +2) sum) + is_last? (_.=== ..unit sum_flag) + test_recursion! (_.if is_last? + ## Must recurse. + ($_ _.then + (_.set! wantedTag (_.- sum_tag wantedTag)) + (_.set! sum sum_value)) + no_match!)] + (<| (_.while (_.bool true)) + (_.cond (list [(_.=== sum_tag wantedTag) + (_.if (_.=== wantsLast sum_flag) + (_.return sum_value) + test_recursion!)] + + [(_.< wantedTag sum_tag) + test_recursion!] + + [(_.=== ..unit wantsLast) + (_.return (sum//make (_.- wantedTag sum_tag) sum_flag sum_value))]) + no_match!)))) + +(def: runtime//adt + Statement + ($_ _.then + @tuple//make + @tuple//left + @tuple//slice + @tuple//right + @sum//make + @sum//get + )) + +(runtime: (lux//try op) + (with_vars [value] + (_.try ($_ _.then + (_.set! value (_.apply/1 op [..unit])) + (_.return (..right value))) + (list (with_vars [error] + {#_.class (_.constant "Exception") + #_.exception error + #_.handler (_.return (..left (_.do "getMessage" (list) error)))}))))) + +(runtime: (lux//program_args inputs) + (with_vars [head tail] + ($_ _.then + (_.set! tail ..none) + (<| (_.for_each (_.array_reverse/1 inputs) head) + (_.set! tail (..some (_.array/* (list head tail))))) + (_.return tail)))) + +(def: runtime//lux + Statement + ($_ _.then + @lux//try + @lux//program_args + )) + +(def: #export high + (-> (I64 Any) (I64 Any)) + (i64.right_shift 32)) + +(def: #export low + (-> (I64 Any) (I64 Any)) + (let [mask (dec (i64.left_shift 32 1))] + (|>> (i64.and mask)))) + +(runtime: (i64//right_shift param subject) + (let [## The mask has to be calculated this way instead of in a more straightforward way + ## because in some languages, 1<<63 = max_negative_value + ## and max_negative_value-1 = max_positive_value. + ## And bitwise, max_positive_value works out to the mask that is desired when param = 0. + ## However, in PHP, max_negative_value-1 underflows and gets cast into a float. + ## And this messes up the computation. + ## This slightly more convoluted calculation avoids that problem. + mask (|> (_.int +1) + (_.bit_shl (_.- param (_.int +63))) + (_.- (_.int +1)) + (_.bit_shl (_.int +1)) + (_.+ (_.int +1)))] + ($_ _.then + (_.set! param (_.% (_.int +64) param)) + (_.if (_.=== (_.int +0) param) + (_.return subject) + (_.return (|> subject + (_.bit_shr param) + (_.bit_and mask))))))) + +(runtime: (i64//char code) + (_.if ..jphp? + (_.return (_.chr/1 [code])) + (_.return (|> code + [(_.string "V")] + _.pack/2 + [(_.string "UTF-32LE") (_.string "UTF-8")] + _.iconv/3)))) + +(runtime: (i64//+ parameter subject) + (let [high_16 (..i64//right_shift (_.int +16)) + low_16 (_.bit_and (_.int (.int (hex "FFFF")))) + + cap_16 low_16 + hh (..i64//right_shift (_.int +48)) + hl (|>> (..i64//right_shift (_.int +32)) cap_16) + lh (|>> (..i64//right_shift (_.int +16)) cap_16) + ll cap_16 + + up_16 (_.bit_shl (_.int +16))] + (with_vars [l48 l32 l16 l00 + r48 r32 r16 r00 + x48 x32 x16 x00] + ($_ _.then + (_.set! l48 (hh subject)) + (_.set! l32 (hl subject)) + (_.set! l16 (lh subject)) + (_.set! l00 (ll subject)) + + (_.set! r48 (hh parameter)) + (_.set! r32 (hl parameter)) + (_.set! r16 (lh parameter)) + (_.set! r00 (ll parameter)) + + (_.set! x00 (_.+ l00 r00)) + + (_.set! x16 (|> (high_16 x00) + (_.+ l16) + (_.+ r16))) + (_.set! x00 (low_16 x00)) + + (_.set! x32 (|> (high_16 x16) + (_.+ l32) + (_.+ r32))) + (_.set! x16 (low_16 x16)) + + (_.set! x48 (|> (high_16 x32) + (_.+ l48) + (_.+ r48) + low_16)) + (_.set! x32 (low_16 x32)) + + (let [high32 (_.bit_or (up_16 x48) x32) + low32 (_.bit_or (up_16 x16) x00)] + (_.return (|> high32 + (_.bit_shl (_.int +32)) + (_.bit_or low32)))) + )))) + +(runtime: (i64//negate value) + (let [i64//min (_.int (.int (hex "80,00,00,00,00,00,00,00")))] + (_.if (_.=== i64//min value) + (_.return i64//min) + (_.return (..i64//+ (_.int +1) (_.bit_not value)))))) + +(runtime: (i64//- parameter subject) + (_.return (..i64//+ (..i64//negate parameter) subject))) + +(runtime: (i64//* parameter subject) + (let [high_16 (..i64//right_shift (_.int +16)) + low_16 (_.bit_and (_.int (.int (hex "FFFF")))) + + cap_16 low_16 + hh (..i64//right_shift (_.int +48)) + hl (|>> (..i64//right_shift (_.int +32)) cap_16) + lh (|>> (..i64//right_shift (_.int +16)) cap_16) + ll cap_16 + + up_16 (_.bit_shl (_.int +16))] + (with_vars [l48 l32 l16 l00 + r48 r32 r16 r00 + x48 x32 x16 x00] + ($_ _.then + (_.set! l48 (hh subject)) + (_.set! l32 (hl subject)) + (_.set! l16 (lh subject)) + (_.set! l00 (ll subject)) + + (_.set! r48 (hh parameter)) + (_.set! r32 (hl parameter)) + (_.set! r16 (lh parameter)) + (_.set! r00 (ll parameter)) + + (_.set! x00 (_.* l00 r00)) + (_.set! x16 (high_16 x00)) + (_.set! x00 (low_16 x00)) + + (_.set! x16 (|> x16 (_.+ (_.* l16 r00)))) + (_.set! x32 (high_16 x16)) (_.set! x16 (low_16 x16)) + (_.set! x16 (|> x16 (_.+ (_.* l00 r16)))) + (_.set! x32 (|> x32 (_.+ (high_16 x16)))) (_.set! x16 (low_16 x16)) + + (_.set! x32 (|> x32 (_.+ (_.* l32 r00)))) + (_.set! x48 (high_16 x32)) (_.set! x32 (low_16 x32)) + (_.set! x32 (|> x32 (_.+ (_.* l16 r16)))) + (_.set! x48 (|> x48 (_.+ (high_16 x32)))) (_.set! x32 (low_16 x32)) + (_.set! x32 (|> x32 (_.+ (_.* l00 r32)))) + (_.set! x48 (|> x48 (_.+ (high_16 x32)))) (_.set! x32 (low_16 x32)) + + (_.set! x48 (|> x48 + (_.+ (_.* l48 r00)) + (_.+ (_.* l32 r16)) + (_.+ (_.* l16 r32)) + (_.+ (_.* l00 r48)) + low_16)) + + (let [high32 (_.bit_or (up_16 x48) x32) + low32 (_.bit_or (up_16 x16) x00)] + (_.return (|> high32 + (_.bit_shl (_.int +32)) + (_.bit_or low32)))) + )))) + +(def: runtime//i64 + Statement + ($_ _.then + @i64//right_shift + @i64//char + @i64//+ + @i64//negate + @i64//- + @i64//* + )) + +(runtime: (text//size value) + (_.if ..jphp? + (_.return (_.strlen/1 [value])) + (_.return (_.iconv_strlen/1 [value])))) + +(runtime: (text//index subject param start) + (_.if (_.=== (_.string "") param) + (_.return (..some (_.int +0))) + (with_vars [idx] + (_.if ..jphp? + ($_ _.then + (_.set! idx (_.strpos/3 [subject param start])) + (_.if (_.=== (_.bool false) idx) + (_.return ..none) + (_.return (..some idx)))) + ($_ _.then + (_.set! idx (_.iconv_strpos/3 [subject param start])) + (_.if (_.=== (_.bool false) idx) + (_.return ..none) + (_.return (..some idx)))))))) + +(def: (within? top value) + (-> Expression Expression Computation) + (_.and (|> value (_.>= (_.int +0))) + (|> value (_.< top)))) + +(runtime: (text//clip offset length text) + (_.if ..jphp? + (_.return (_.substr/3 [text offset length])) + (_.return (_.iconv_substr/3 [text offset length])))) + +(runtime: (text//char idx text) + (_.if (|> idx (within? (text//size text))) + (_.if ..jphp? + (_.return (_.ord/1 (_.substr/3 [text idx (_.int +1)]))) + (_.return (|> (_.iconv_substr/3 [text idx (_.int +1)]) + [(_.string "UTF-8") (_.string "UTF-32LE")] + _.iconv/3 + [(_.string "V")] + _.unpack/2 + (_.nth (_.int +1))))) + (_.throw (_.new (_.constant "Exception") (list (_.string "[Lux Error] Cannot get char from text.")))))) + +(def: runtime//text + Statement + ($_ _.then + @text//size + @text//index + @text//clip + @text//char + )) + +(runtime: (f64//decode value) + (with_vars [output] + ($_ _.then + (_.set! output (_.floatval/1 value)) + (_.if (_.=== (_.float +0.0) output) + (_.if ($_ _.or + (_.=== (_.string "0.0") output) + (_.=== (_.string "+0.0") output) + (_.=== (_.string "-0.0") output) + (_.=== (_.string "0") output) + (_.=== (_.string "+0") output) + (_.=== (_.string "-0") output)) + (_.return (..some output)) + (_.return ..none)) + (_.return (..some output))) + ))) + +(def: runtime//f64 + Statement + ($_ _.then + @f64//decode + )) + +(def: check_necessary_conditions! + Statement + (let [i64_support? (_.=== (_.int +8) (_.constant "PHP_INT_SIZE")) + i64_error (_.string (format "Cannot run program!" text.new_line + "Lux/PHP programs require 64-bit PHP builds!"))] + (_.when (_.not i64_support?) + (_.throw (_.new (_.constant "Exception") (list i64_error)))))) + +(def: runtime + Statement + ($_ _.then + check_necessary_conditions! + runtime//array + runtime//adt + runtime//lux + runtime//i64 + runtime//f64 + runtime//text + runtime//io + )) + +(def: #export generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! ..module_id ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row [..module_id + (|> ..runtime + _.code + (\ utf8.codec encode))])]))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/structure.lux new file mode 100644 index 000000000..8d9334dca --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/structure.lux @@ -0,0 +1,42 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [data + [collection + ["." list]]] + [target + ["_" php (#+ Expression)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." primitive] + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + ["//#" /// #_ + ["#." phase ("#\." monad)]]]]) + +(def: #export (tuple expression archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + #.Nil + (///////phase\wrap (//primitive.text /////synthesis.unit)) + + (#.Cons singletonS #.Nil) + (expression archive singletonS) + + _ + (let [size (_.int (.int (list.size elemsS+)))] + (|> elemsS+ + (monad.map ///////phase.monad (expression archive)) + (///////phase\map (|>> _.array/* + (//runtime.tuple//make size))))))) + +(def: #export (variant expression archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (inc lefts) + lefts)] + (///////phase\map (//runtime.variant tag right?) + (expression archive valueS)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python.lux new file mode 100644 index 000000000..683a64ffe --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python.lux @@ -0,0 +1,113 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." exception (#+ exception:)]] + [target + ["_" python]]]] + ["." / #_ + [runtime (#+ Phase Phase!)] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." function] + ["#." case] + ["#." loop] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + [analysis (#+)] + ["#." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) + +(def: (statement expression archive synthesis) + Phase! + (case synthesis + (^template [<tag>] + [(^ (<tag> value)) + (//////phase\map _.return (expression archive synthesis))]) + ([////synthesis.bit] + [////synthesis.i64] + [////synthesis.f64] + [////synthesis.text] + [////synthesis.variant] + [////synthesis.tuple] + [#////synthesis.Reference] + [////synthesis.branch/get] + [////synthesis.function/apply] + [#////synthesis.Extension]) + + (^ (////synthesis.branch/case case)) + (/case.case! false statement expression archive case) + + (^template [<tag> <generator>] + [(^ (<tag> value)) + (<generator> statement expression archive value)]) + ([////synthesis.branch/let /case.let!] + [////synthesis.branch/if /case.if!] + [////synthesis.loop/scope /loop.scope!] + [////synthesis.loop/recur /loop.recur!]) + + (^ (////synthesis.function/abstraction abstraction)) + (//////phase\map _.return (/function.function statement expression archive abstraction)) + )) + +(exception: #export cannot-recur-as-an-expression) + +(def: #export (expression archive synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + [(^ (<tag> value)) + (//////phase\wrap (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + (^ (////synthesis.variant variantS)) + (/structure.variant expression archive variantS) + + (^ (////synthesis.tuple members)) + (/structure.tuple expression archive members) + + (#////synthesis.Reference value) + (//reference.reference /reference.system archive value) + + (^ (////synthesis.branch/case case)) + (/case.case ..statement expression archive case) + + (^ (////synthesis.branch/let let)) + (/case.let expression archive let) + + (^ (////synthesis.branch/if if)) + (/case.if expression archive if) + + (^ (////synthesis.branch/get get)) + (/case.get expression archive get) + + (^ (////synthesis.loop/scope scope)) + (/loop.scope ..statement expression archive scope) + + (^ (////synthesis.loop/recur updates)) + (//////phase.throw ..cannot-recur-as-an-expression []) + + (^ (////synthesis.function/abstraction abstraction)) + (/function.function ..statement expression archive abstraction) + + (^ (////synthesis.function/apply application)) + (/function.apply expression archive application) + + (#////synthesis.Extension extension) + (///extension.apply archive expression extension))) + +(def: #export generate + Phase + ..expression) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/case.lux new file mode 100644 index 000000000..a4e5e81fc --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/case.lux @@ -0,0 +1,334 @@ +(.module: + [library + [lux (#- case let if) + [abstract + ["." monad (#+ do)]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set]]] + [math + [number + ["n" nat] + ["i" int]]] + [target + ["_" python (#+ Expression SVar Statement)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator Phase! Generator!)] + ["#." reference] + ["#." primitive] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + [synthesis + ["." case]] + ["/#" // #_ + ["#." synthesis (#+ Member Synthesis Path)] + ["#." generation] + ["//#" /// #_ + [reference + ["#." variable (#+ Register)]] + ["#." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]]) + +(def: #export (gensym prefix) + (-> Text (Operation SVar)) + (///////phase\map (|>> %.nat (format prefix) _.var) + /////generation.next)) + +(def: #export register + (-> Register SVar) + (|>> (///reference.local //reference.system) :assume)) + +(def: #export capture + (-> Register SVar) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: #export (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + ## TODO: Find some way to do 'let' without paying the price of the closure. + (wrap (_.apply/* (_.lambda (list (..register register)) + bodyO) + (list valueO))))) + +(def: #export (let! statement expression archive [valueS register bodyS]) + (Generator! [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (statement expression archive bodyS)] + (wrap ($_ _.then + (_.set (list (..register register)) valueO) + bodyO)))) + +(def: #export (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (wrap (_.? testO thenO elseO)))) + +(def: #export (if! statement expression archive [testS thenS elseS]) + (Generator! [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [test! (expression archive testS) + then! (statement expression archive thenS) + else! (statement expression archive elseS)] + (wrap (_.if test! + then! + else!)))) + +(def: #export (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (wrap (list\fold (function (_ side source) + (.let [method (.case side + (^template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.int (.int lefts)))]) + ([#.Left //runtime.tuple::left] + [#.Right //runtime.tuple::right]))] + (method source))) + valueO + (list.reverse pathP))))) + +(def: @savepoint (_.var "lux_pm_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) + +(def: (push! value) + (-> (Expression Any) (Statement Any)) + (_.statement (|> @cursor (_.do "append" (list value))))) + +(def: peek_and_pop + (Expression Any) + (|> @cursor (_.do "pop" (list)))) + +(def: pop! + (Statement Any) + (_.statement ..peek_and_pop)) + +(def: peek + (Expression Any) + (_.nth (_.int -1) @cursor)) + +(def: save! + (Statement Any) + (.let [cursor (_.slice_from (_.int +0) @cursor)] + (_.statement (|> @savepoint (_.do "append" (list cursor)))))) + +(def: restore! + (Statement Any) + (_.set (list @cursor) (|> @savepoint (_.do "pop" (list))))) + +(def: fail_pm! _.break) + +(def: (multi_pop! pops) + (-> Nat (Statement Any)) + (_.delete (_.slice_from (_.int (i.* -1 (.int pops))) @cursor))) + +(template [<name> <flag> <prep>] + [(def: (<name> simple? idx) + (-> Bit Nat (Statement Any)) + ($_ _.then + (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum::get ..peek <flag>))) + (.if simple? + (_.when (_.= _.none @temp) + fail_pm!) + (_.if (_.= _.none @temp) + fail_pm! + (..push! @temp)) + )))] + + [left_choice _.none (<|)] + [right_choice (_.string "") inc] + ) + +(def: (with_looping in_closure? g!once body!) + (-> Bit SVar (Statement Any) (Statement Any)) + (.if in_closure? + (_.while (_.bool true) + body! + #.None) + ($_ _.then + (_.set (list g!once) (_.bool true)) + (_.while g!once + ($_ _.then + (_.set (list g!once) (_.bool false)) + body!) + (#.Some _.continue))))) + +(def: (alternation in_closure? g!once pre! post!) + (-> Bit SVar (Statement Any) (Statement Any) (Statement Any)) + ($_ _.then + (..with_looping in_closure? g!once + ($_ _.then + ..save! + pre!)) + ..restore! + post!)) + +(def: (primitive_pattern_matching recur pathP) + (-> (-> Path (Operation (Statement Any))) + (-> Path (Operation (Maybe (Statement Any))))) + (.case pathP + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail_pm!))] + (wrap (#.Some (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!))))) + + (^template [<tag> <format>] + [(<tag> cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (\ ! map + (|>> [(_.= (|> match <format>) + ..peek)]) + (recur then))) + (#.Cons cons))] + (wrap (#.Some (_.cond clauses + ..fail_pm!))))]) + ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)] + [#/////synthesis.F64_Fork (<| //primitive.f64)] + [#/////synthesis.Text_Fork (<| //primitive.text)]) + + _ + (\ ///////phase.monad wrap #.None))) + +(def: (pattern_matching' in_closure? statement expression archive) + (-> Bit Phase! Phase Archive Path (Operation (Statement Any))) + (function (recur pathP) + (do {! ///////phase.monad} + [?output (primitive_pattern_matching recur pathP)] + (.case ?output + (#.Some output) + (wrap output) + + #.None + (.case pathP + (#/////synthesis.Then bodyS) + (statement expression archive bodyS) + + #/////synthesis.Pop + (///////phase\wrap ..pop!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.set (list (..register register)) ..peek)) + + (^template [<complex> <simple> <choice>] + [(^ (<complex> idx)) + (///////phase\wrap (<choice> false idx)) + + (^ (<simple> idx nextP)) + (|> nextP + recur + (///////phase\map (_.then (<choice> true idx))))]) + ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] + [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!)) + + (^template [<pm> <getter>] + [(^ (<pm> lefts)) + (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) + ([/////synthesis.member/left //runtime.tuple::left] + [/////synthesis.member/right //runtime.tuple::right]) + + (^ (/////synthesis.!bind_top register thenP)) + (do ! + [then! (recur thenP)] + (///////phase\wrap ($_ _.then + (_.set (list (..register register)) ..peek_and_pop) + then!))) + + (^ (/////synthesis.!multi_pop nextP)) + (.let [[extra_pops nextP'] (case.count_pops nextP)] + (do ! + [next! (recur nextP')] + (///////phase\wrap ($_ _.then + (..multi_pop! (n.+ 2 extra_pops)) + next!)))) + + (^ (/////synthesis.path/seq preP postP)) + (do ! + [pre! (recur preP) + post! (recur postP)] + (wrap (_.then pre! post!))) + + (^ (/////synthesis.path/alt preP postP)) + (do ! + [pre! (recur preP) + post! (recur postP) + g!once (..gensym "once")] + (wrap (..alternation in_closure? g!once pre! post!))) + + _ + (undefined)))))) + +(def: (pattern_matching in_closure? statement expression archive pathP) + (-> Bit Phase! Phase Archive Path (Operation (Statement Any))) + (do ///////phase.monad + [pattern_matching! (pattern_matching' in_closure? statement expression archive pathP) + g!once (..gensym "once")] + (wrap ($_ _.then + (..with_looping in_closure? g!once + pattern_matching!) + (_.raise (_.Exception/1 (_.string case.pattern_matching_error))))))) + +(def: #export dependencies + (-> Path (List SVar)) + (|>> case.storage + (get@ #case.dependencies) + set.to_list + (list\map (function (_ variable) + (.case variable + (#///////variable.Local register) + (..register register) + + (#///////variable.Foreign register) + (..capture register)))))) + +(def: #export (case! in_closure? statement expression archive [valueS pathP]) + (-> Bit (Generator! [Synthesis Path])) + (do ///////phase.monad + [stack_init (expression archive valueS) + pattern_matching! (pattern_matching in_closure? statement expression archive pathP)] + (wrap ($_ _.then + (_.set (list @cursor) (_.list (list stack_init))) + (_.set (list @savepoint) (_.list (list))) + pattern_matching! + )))) + +(def: #export (case statement expression archive [valueS pathP]) + (-> Phase! (Generator [Synthesis Path])) + (do ///////phase.monad + [[[case_module case_artifact] pattern_matching!] (/////generation.with_new_context archive + (case! true statement expression archive [valueS pathP])) + #let [@case (_.var (///reference.artifact [case_module case_artifact])) + @dependencies+ (..dependencies (/////synthesis.path/seq (/////synthesis.path/then valueS) + pathP)) + directive (_.def @case @dependencies+ + pattern_matching!)] + _ (/////generation.execute! directive) + _ (/////generation.save! case_artifact directive)] + (wrap (_.apply/* @case @dependencies+)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/function.lux new file mode 100644 index 000000000..ca18fb0ef --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/function.lux @@ -0,0 +1,112 @@ +(.module: + [library + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [target + ["_" python (#+ SVar Expression Statement)]]]] + ["." // #_ + [runtime (#+ Operation Phase Generator Phase! Generator!)] + ["#." reference] + ["#." case] + ["#." loop] + ["/#" // #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["#." generation (#+ Context)] + ["//#" /// #_ + [arity (#+ Arity)] + ["#." phase] + [reference + [variable (#+ Register Variable)]] + [meta + [archive (#+ Archive) + ["." artifact]]]]]]]) + +(def: #export (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do {! ///////phase.monad} + [functionO (expression archive functionS) + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply/* functionO argsO+)))) + +(def: #export capture + (-> Register SVar) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: (with_closure function_id @function inits function_definition) + (-> artifact.ID SVar (List (Expression Any)) (Statement Any) (Operation (Expression Any))) + (case inits + #.Nil + (do ///////phase.monad + [_ (/////generation.execute! function_definition) + _ (/////generation.save! function_id function_definition)] + (wrap @function)) + + _ + (do {! ///////phase.monad} + [#let [directive (_.def @function + (|> (list.enumeration inits) + (list\map (|>> product.left ..capture))) + ($_ _.then + function_definition + (_.return @function)))] + _ (/////generation.execute! directive) + _ (/////generation.save! function_id directive)] + (wrap (_.apply/* @function inits))))) + +(def: input + (|>> inc //case.register)) + +(def: #export (function statement expression archive [environment arity bodyS]) + (-> Phase! (Generator (Abstraction Synthesis))) + (do {! ///////phase.monad} + [[[function_module function_artifact] body!] (/////generation.with_new_context archive + (/////generation.with_anchor 1 + (statement expression archive bodyS))) + environment (monad.map ! (expression archive) environment) + #let [@curried (_.var "curried") + arityO (|> arity .int _.int) + @num_args (_.var "num_args") + @self (_.var (///reference.artifact [function_module function_artifact])) + apply_poly (.function (_ args func) + (_.apply_poly (list) args func)) + initialize_self! (_.set (list (//case.register 0)) @self) + initialize! (list\fold (.function (_ post pre!) + ($_ _.then + pre! + (_.set (list (..input post)) (_.nth (|> post .int _.int) @curried)))) + initialize_self! + (list.indices arity))]] + (with_closure function_artifact @self environment + (_.def @self (list (_.poly @curried)) + ($_ _.then + (_.set (list @num_args) (_.len/1 @curried)) + (_.cond (list [(|> @num_args (_.= arityO)) + (<| (_.then initialize!) + //loop.set_scope + body!)] + [(|> @num_args (_.> arityO)) + (let [arity_inputs (_.slice (_.int +0) arityO @curried) + extra_inputs (_.slice arityO @num_args @curried)] + (_.return (|> @self + (apply_poly arity_inputs) + (apply_poly extra_inputs))))]) + ## (|> @num_args (_.< arityO)) + (let [@next (_.var "next") + @missing (_.var "missing")] + ($_ _.then + (_.def @next (list (_.poly @missing)) + (_.return (|> @self (apply_poly (|> @curried (_.+ @missing)))))) + (_.return @next) + ))) + ))) + )) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/loop.lux new file mode 100644 index 000000000..353c890f9 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/loop.lux @@ -0,0 +1,122 @@ +(.module: + [library + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set]]] + [math + [number + ["n" nat]]] + [target + ["_" python (#+ Expression SVar Statement)]]]] + ["." // #_ + [runtime (#+ Operation Phase Generator Phase! Generator!)] + ["#." case] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + [synthesis + ["." case]] + ["/#" // #_ + ["." synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [reference + ["#." variable (#+ Register)]]]]]]]) + +(def: (setup offset bindings body) + (-> Register (List (Expression Any)) (Statement Any) (Statement Any)) + (|> bindings + list.enumeration + (list\map (function (_ [register value]) + (_.set (list (//case.register (n.+ offset register))) + value))) + list.reverse + (list\fold _.then body))) + +(def: #export (set_scope body!) + (-> (Statement Any) (Statement Any)) + (_.while (_.bool true) + body! + #.None)) + +(def: #export (scope! statement expression archive [start initsS+ bodyS]) + (Generator! (Scope Synthesis)) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (statement expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [initsO+ (monad.map ! (expression archive) initsS+) + body! (/////generation.with_anchor start + (statement expression archive bodyS))] + (wrap (<| (..setup start initsO+) + ..set_scope + body!))))) + +(def: #export (scope statement expression archive [start initsS+ bodyS]) + (-> Phase! (Generator (Scope Synthesis))) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [initsO+ (monad.map ! (expression archive) initsS+) + [[loop_module loop_artifact] body!] (/////generation.with_new_context archive + (/////generation.with_anchor start + (statement expression archive bodyS))) + #let [@loop (_.var (///reference.artifact [loop_module loop_artifact])) + locals (|> initsS+ + list.enumeration + (list\map (|>> product.left (n.+ start) //case.register))) + actual_loop (<| (_.def @loop locals) + ..set_scope + body!) + [directive instantiation] (: [(Statement Any) (Expression Any)] + (case (|> (synthesis.path/then bodyS) + //case.dependencies + (set.from_list _.hash) + (set.difference (set.from_list _.hash locals)) + set.to_list) + #.Nil + [actual_loop + @loop] + + foreigns + [(_.def @loop foreigns + ($_ _.then + actual_loop + (_.return @loop) + )) + (_.apply/* @loop foreigns)]))] + _ (/////generation.execute! directive) + _ (/////generation.save! loop_artifact directive)] + (wrap (_.apply/* instantiation initsO+))))) + +(def: #export (recur! statement expression archive argsS+) + (Generator! (List Synthesis)) + (do {! ///////phase.monad} + [offset /////generation.anchor + @temp (//case.gensym "lux_recur_values") + argsO+ (monad.map ! (expression archive) argsS+) + #let [re_binds (|> argsO+ + list.enumeration + (list\map (function (_ [idx _]) + (_.nth (_.int (.int idx)) @temp))))]] + (wrap ($_ _.then + (_.set (list @temp) (_.list argsO+)) + (..setup offset re_binds + _.continue))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux new file mode 100644 index 000000000..60175358f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux @@ -0,0 +1,18 @@ +(.module: + [library + [lux (#- i64) + [target + ["_" python (#+ Expression)]]]] + ["." // #_ + ["#." runtime]]) + +(template [<type> <name> <implementation>] + [(def: #export <name> + (-> <type> (Expression Any)) + <implementation>)] + + [Bit bit _.bool] + [(I64 Any) i64 (|>> .int _.int //runtime.i64::64)] + [Frac f64 _.float] + [Text text _.unicode] + ) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/reference.lux new file mode 100644 index 000000000..eeb4604a3 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" python (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System (Expression Any)) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux new file mode 100644 index 000000000..1b7c4310c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux @@ -0,0 +1,456 @@ +(.module: + [library + [lux (#- inc) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<.>" code]]] + [data + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." list ("#\." functor)] + ["." row]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["f" frac] + ["." i64]]] + ["@" target + ["_" python (#+ Expression SVar Computation Literal Statement)]]]] + ["." /// #_ + ["#." reference] + ["//#" /// #_ + ["$" version] + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// + ["#." phase] + [reference + [variable (#+ Register)]] + [meta + [archive (#+ Output Archive) + ["." artifact (#+ Registry)]]]]]]) + +(template [<name> <base>] + [(type: #export <name> + (<base> Register (Expression Any) (Statement Any)))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type: #export Phase! + (-> Phase Archive Synthesis (Operation (Statement Any)))) + +(type: #export (Generator! i) + (-> Phase! Phase Archive i (Operation (Statement Any)))) + +(type: #export (Generator i) + (-> Phase Archive i (Operation (Expression Any)))) + +(def: prefix + "LuxRuntime") + +(def: #export + unit + (_.unicode /////synthesis.unit)) + +(def: (flag value) + (-> Bit Literal) + (if value + ..unit + _.none)) + +(def: (variant' tag last? value) + (-> (Expression Any) (Expression Any) (Expression Any) Literal) + (_.tuple (list tag last? value))) + +(def: #export (variant tag last? value) + (-> Nat Bit (Expression Any) Literal) + (variant' (_.int (.int tag)) + (flag last?) + value)) + +(def: #export none + Literal + (..variant 0 #0 unit)) + +(def: #export some + (-> (Expression Any) Literal) + (..variant 1 #1)) + +(def: #export left + (-> (Expression Any) Literal) + (..variant 0 #0)) + +(def: #export right + (-> (Expression Any) Literal) + (..variant 1 #1)) + +(def: (runtime_name name) + (-> Text SVar) + (let [identifier (format ..prefix + "_" (%.nat $.version) + "_" (%.nat (text\hash name)))] + (_.var identifier))) + +(def: (feature name definition) + (-> SVar (-> SVar (Statement Any)) (Statement Any)) + (definition name)) + +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} + body) + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} + code) + (case declaration + (#.Left name) + (macro.with_gensyms [g!_] + (let [nameC (code.local_identifier name) + code_nameC (code.local_identifier (format "@" name)) + runtime_nameC (` (runtime_name (~ (code.text name))))] + (wrap (list (` (def: #export (~ nameC) SVar (~ runtime_nameC))) + (` (def: (~ code_nameC) + (Statement Any) + (..feature (~ runtime_nameC) + (function ((~ g!_) (~ g!_)) + (_.set (list (~ g!_)) (~ code)))))))))) + + (#.Right [name inputs]) + (macro.with_gensyms [g!_] + (let [nameC (code.local_identifier name) + code_nameC (code.local_identifier (format "@" name)) + runtime_nameC (` (runtime_name (~ (code.text name)))) + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` (_.Expression Any))) + inputs)] + (wrap (list (` (def: #export ((~ nameC) (~+ inputsC)) + (-> (~+ inputs_typesC) (Computation Any)) + (_.apply/* (~ runtime_nameC) (list (~+ inputsC))))) + (` (def: (~ code_nameC) + (Statement Any) + (..feature (~ runtime_nameC) + (function ((~ g!_) (~ g!_)) + (..with_vars [(~+ inputsC)] + (_.def (~ g!_) (list (~+ inputsC)) + (~ code))))))))))))) + +(runtime: (lux::try op) + (with_vars [exception] + (_.try (_.return (..right (_.apply/* op (list ..unit)))) + (list [(list (_.var "Exception")) exception + (_.return (..left (_.str/1 exception)))])))) + +(runtime: (lux::program_args program_args) + (with_vars [inputs value] + ($_ _.then + (_.set (list inputs) ..none) + (<| (_.for_in value (_.apply/* (_.var "reversed") (list program_args))) + (_.set (list inputs) + (..some (_.list (list value inputs))))) + (_.return inputs)))) + +(runtime: (lux::exec code globals) + ($_ _.then + (_.exec code (#.Some globals)) + (_.return ..unit))) + +(def: runtime::lux + (Statement Any) + ($_ _.then + @lux::try + @lux::program_args + @lux::exec + )) + +(runtime: (io::log! message) + ($_ _.then + (_.print message) + (_.return ..unit))) + +(runtime: (io::throw! message) + (_.raise (_.Exception/1 message))) + +(def: runtime::io + (Statement Any) + ($_ _.then + @io::log! + @io::throw! + )) + +(def: last_index + (|>> _.len/1 (_.- (_.int +1)))) + +(with_expansions [<recur> (as_is ($_ _.then + (_.set (list lefts) (_.- last_index_right lefts)) + (_.set (list tuple) (_.nth last_index_right tuple))))] + (runtime: (tuple::left lefts tuple) + (with_vars [last_index_right] + (_.while (_.bool true) + ($_ _.then + (_.set (list last_index_right) (..last_index tuple)) + (_.if (_.> lefts last_index_right) + ## No need for recursion + (_.return (_.nth lefts tuple)) + ## Needs recursion + <recur>)) + #.None))) + + (runtime: (tuple::right lefts tuple) + (with_vars [last_index_right right_index] + (_.while (_.bool true) + ($_ _.then + (_.set (list last_index_right) (..last_index tuple)) + (_.set (list right_index) (_.+ (_.int +1) lefts)) + (_.cond (list [(_.= last_index_right right_index) + (_.return (_.nth right_index tuple))] + [(_.> last_index_right right_index) + ## Needs recursion. + <recur>]) + (_.return (_.slice_from right_index tuple)))) + #.None)))) + +(runtime: (sum::get sum wantsLast wantedTag) + (let [no_match! (_.return _.none) + sum_tag (_.nth (_.int +0) sum) + sum_flag (_.nth (_.int +1) sum) + sum_value (_.nth (_.int +2) sum) + is_last? (_.= ..unit sum_flag) + test_recursion! (_.if is_last? + ## Must recurse. + ($_ _.then + (_.set (list wantedTag) (_.- sum_tag wantedTag)) + (_.set (list sum) sum_value)) + no_match!)] + (_.while (_.bool true) + (_.cond (list [(_.= wantedTag sum_tag) + (_.if (_.= wantsLast sum_flag) + (_.return sum_value) + test_recursion!)] + + [(_.< wantedTag sum_tag) + test_recursion!] + + [(_.= ..unit wantsLast) + (_.return (variant' (_.- wantedTag sum_tag) sum_flag sum_value))]) + + no_match!) + #.None))) + +(def: runtime::adt + (Statement Any) + ($_ _.then + @tuple::left + @tuple::right + @sum::get + )) + +(def: i64::+limit (_.manual "+0x7FFFFFFFFFFFFFFF")) +(def: i64::-limit (_.manual "-0x8000000000000000")) +(def: i64::+iteration (_.manual "+0x10000000000000000")) +(def: i64::-iteration (_.manual "-0x10000000000000000")) +(def: i64::+cap (_.manual "+0x8000000000000000")) +(def: i64::-cap (_.manual "-0x8000000000000001")) + +(runtime: (i64::64 input) + (with_vars [temp] + (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>] + [(_.if (|> input <scenario>) + ($_ _.then + (_.set (list temp) (_.% <iteration> input)) + (_.return (_.? (|> temp <scenario>) + (|> temp (_.- <cap>) (_.+ <entrance>)) + temp))))] + + [(_.> ..i64::+limit) ..i64::+iteration ..i64::+cap ..i64::-limit] + [(_.< ..i64::-limit) ..i64::-iteration ..i64::-cap ..i64::+limit] + )) + (_.return (for {@.python input} + ## This +- is only necessary to guarantee that values within the limits are always longs in Python 2 + (|> input (_.+ ..i64::+limit) (_.- ..i64::+limit)))))))) + +(def: as_nat + (_.% ..i64::+iteration)) + +(runtime: (i64::left_shift param subject) + (_.return (|> subject + (_.bit_shl (_.% (_.int +64) param)) + ..i64::64))) + +(runtime: (i64::right_shift param subject) + ($_ _.then + (_.set (list param) (_.% (_.int +64) param)) + (_.return (_.? (_.= (_.int +0) param) + subject + (|> subject + ..as_nat + (_.bit_shr param)))))) + +(runtime: (i64::division param subject) + (with_vars [floored] + ($_ _.then + (_.set (list floored) (_.// param subject)) + (_.return (let [potentially_floored? (_.< (_.int +0) floored) + inexact? (|> subject + (_.% param) + (_.= (_.int +0)) + _.not)] + (_.? (_.and potentially_floored? + inexact?) + (_.+ (_.int +1) floored) + floored)))))) + +(runtime: (i64::remainder param subject) + (_.return (_.- (|> subject (..i64::division param) (_.* param)) + subject))) + +(template [<runtime> <host>] + [(runtime: (<runtime> left right) + (_.return (..i64::64 (<host> (..as_nat left) (..as_nat right)))))] + + [i64::and _.bit_and] + [i64::or _.bit_or] + [i64::xor _.bit_xor] + ) + +(def: python_version + (Expression Any) + (|> (_.__import__/1 (_.unicode "sys")) + (_.the "version_info") + (_.the "major"))) + +(runtime: (i64::char value) + (_.return (_.? (_.= (_.int +3) ..python_version) + (_.chr/1 value) + (_.unichr/1 value)))) + +(def: runtime::i64 + (Statement Any) + ($_ _.then + @i64::64 + @i64::left_shift + @i64::right_shift + @i64::division + @i64::remainder + @i64::and + @i64::or + @i64::xor + @i64::char + )) + +(runtime: (f64::/ parameter subject) + (_.return (_.? (_.= (_.float +0.0) parameter) + (<| (_.? (_.> (_.float +0.0) subject) + (_.float f.positive_infinity)) + (_.? (_.< (_.float +0.0) subject) + (_.float f.negative_infinity)) + (_.float f.not_a_number)) + (_./ parameter subject)))) + +(runtime: (f64::decode input) + (with_vars [ex] + (_.try + (_.return (..some (_.float/1 input))) + (list [(list (_.var "Exception")) ex + (_.return ..none)])))) + +(def: runtime::f64 + (Statement Any) + ($_ _.then + @f64::/ + @f64::decode + )) + +(runtime: (text::index start param subject) + (with_vars [idx] + ($_ _.then + (_.set (list idx) (|> subject (_.do "find" (list param start)))) + (_.return (_.? (_.= (_.int -1) idx) + ..none + (..some (..i64::64 idx))))))) + +(def: inc + (|>> (_.+ (_.int +1)))) + +(def: (within? top value) + (-> (Expression Any) (Expression Any) (Computation Any)) + (_.and (|> value (_.>= (_.int +0))) + (|> value (_.< top)))) + +(runtime: (text::clip @offset @length @text) + (_.return (|> @text (_.slice @offset (_.+ @offset @length))))) + +(runtime: (text::char idx text) + (_.if (|> idx (within? (_.len/1 text))) + (_.return (|> text (_.slice idx (..inc idx)) _.ord/1 ..i64::64)) + (_.raise (_.Exception/1 (_.unicode "[Lux Error] Cannot get char from text."))))) + +(def: runtime::text + (Statement Any) + ($_ _.then + @text::index + @text::clip + @text::char + )) + +(runtime: (array::write idx value array) + ($_ _.then + (_.set (list (_.nth idx array)) value) + (_.return array))) + +(def: runtime::array + (Statement Any) + ($_ _.then + @array::write + )) + +(def: runtime + (Statement Any) + ($_ _.then + runtime::lux + runtime::io + runtime::adt + runtime::i64 + runtime::f64 + runtime::text + runtime::array + )) + +(def: module_id + 0) + +(def: #export generate + (Operation [Registry Output]) + (/////generation.with_buffer + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! ..module_id ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row [..module_id + (|> ..runtime + _.code + (\ utf8.codec encode))])])))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/structure.lux new file mode 100644 index 000000000..342e180d0 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/structure.lux @@ -0,0 +1,37 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [target + ["_" python (#+ Expression)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." primitive] + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + ["//#" /// #_ + ["#." phase ("#\." monad)]]]]) + +(def: #export (tuple generate archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + #.Nil + (///////phase\wrap (//primitive.text /////synthesis.unit)) + + (#.Cons singletonS #.Nil) + (generate archive singletonS) + + _ + (|> elemsS+ + (monad.map ///////phase.monad (generate archive)) + (///////phase\map _.list)))) + +(def: #export (variant generate archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (inc lefts) + lefts)] + (///////phase\map (//runtime.variant tag right?) + (generate archive valueS)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r.lux new file mode 100644 index 000000000..d3636709a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r.lux @@ -0,0 +1,59 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [target + ["_" r]]]] + ["." / #_ + [runtime (#+ Phase)] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." loop] + ["#." function] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + [analysis (#+)] + ["#." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) + +(def: #export (generate archive synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + [(^ (<tag> value)) + (//////phase\wrap (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + (#////synthesis.Reference value) + (//reference.reference /reference.system archive value) + + (^template [<tag> <generator>] + [(^ (<tag> value)) + (<generator> generate archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + [////synthesis.function/apply /function.apply] + + [////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.loop/recur /loop.recur] + [////synthesis.function/abstraction /function.function]) + + (#////synthesis.Extension extension) + (///extension.apply archive generate extension) + )) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/case.lux new file mode 100644 index 000000000..912b7aff7 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/case.lux @@ -0,0 +1,240 @@ +(.module: + [library + [lux (#- case let if) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set]]] + [macro + ["." template]] + [math + [number + ["i" int]]] + [target + ["_" r (#+ Expression SVar)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] + ["#." primitive] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." synthesis #_ + ["#/." case]] + ["/#" // #_ + ["#." synthesis (#+ Member Synthesis Path)] + ["#." generation] + ["//#" /// #_ + [reference + ["#." variable (#+ Register)]] + ["#." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]]) + +(def: #export register + (-> Register SVar) + (|>> (///reference.local //reference.system) :assume)) + +(def: #export capture + (-> Register SVar) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: #export (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + (wrap (_.block + ($_ _.then + (_.set! (..register register) valueO) + bodyO))))) + +(def: #export (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (wrap (_.if testO thenO elseO)))) + +(def: #export (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (wrap (list\fold (function (_ side source) + (.let [method (.case side + (^template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.int (.int lefts)))]) + ([#.Left //runtime.tuple::left] + [#.Right //runtime.tuple::right]))] + (method source))) + valueO + (list.reverse pathP))))) + +(def: $savepoint (_.var "lux_pm_cursor_savepoint")) +(def: $cursor (_.var "lux_pm_cursor")) +(def: $temp (_.var "lux_pm_temp")) +(def: $alt_error (_.var "alt_error")) + +(def: top + _.length) + +(def: next + (|>> _.length (_.+ (_.int +1)))) + +(def: (push! value var) + (-> Expression SVar Expression) + (_.set_nth! (next var) value var)) + +(def: (pop! var) + (-> SVar Expression) + (_.set_nth! (top var) _.null var)) + +(def: (push_cursor! value) + (-> Expression Expression) + (push! value $cursor)) + +(def: save_cursor! + Expression + (push! (_.slice (_.float +1.0) (_.length $cursor) $cursor) + $savepoint)) + +(def: restore_cursor! + Expression + (_.set! $cursor (_.nth (top $savepoint) $savepoint))) + +(def: peek + Expression + (|> $cursor (_.nth (top $cursor)))) + +(def: pop_cursor! + Expression + (pop! $cursor)) + +(def: error + (_.string (template.with_locals [error] + (template.text [error])))) + +(def: fail! + (_.stop ..error)) + +(def: (catch handler) + (-> Expression Expression) + (_.function (list $alt_error) + (_.if (|> $alt_error (_.= ..error)) + handler + (_.stop $alt_error)))) + +(def: (pattern_matching' expression archive) + (Generator Path) + (function (recur pathP) + (.case pathP + (#/////synthesis.Then bodyS) + (expression archive bodyS) + + #/////synthesis.Pop + (///////phase\wrap ..pop_cursor!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.set! (..register register) ..peek)) + + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail!))] + (wrap (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^template [<tag> <format> <=>] + [(<tag> cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (do ! + [then! (recur then)] + (wrap [(<=> (|> match <format>) + ..peek) + then!]))) + (#.Cons cons))] + (wrap (list\fold (function (_ [when then] else) + (_.if when then else)) + ..fail! + clauses)))]) + ([#/////synthesis.I64_Fork //primitive.i64 //runtime.i64::=] + [#/////synthesis.F64_Fork //primitive.f64 _.=] + [#/////synthesis.Text_Fork //primitive.text _.=]) + + (^template [<pm> <flag> <prep>] + [(^ (<pm> idx)) + (///////phase\wrap ($_ _.then + (_.set! $temp (|> idx <prep> .int _.int (//runtime.sum::get ..peek (//runtime.flag <flag>)))) + (_.if (_.= _.null $temp) + ..fail! + (..push_cursor! $temp))))]) + ([/////synthesis.side/left false (<|)] + [/////synthesis.side/right true inc]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (_.nth (_.int +1) ..peek)) + + (^template [<pm> <getter>] + [(^ (<pm> lefts)) + (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push_cursor!))]) + ([/////synthesis.member/left //runtime.tuple::left] + [/////synthesis.member/right //runtime.tuple::right]) + + (^ (/////synthesis.path/seq leftP rightP)) + (do ///////phase.monad + [leftO (recur leftP) + rightO (recur rightP)] + (wrap ($_ _.then + leftO + rightO))) + + (^ (/////synthesis.path/alt leftP rightP)) + (do {! ///////phase.monad} + [leftO (recur leftP) + rightO (recur rightP)] + (wrap (_.try ($_ _.then + ..save_cursor! + leftO) + #.None + (#.Some (..catch ($_ _.then + ..restore_cursor! + rightO))) + #.None))) + ))) + +(def: (pattern_matching expression archive pathP) + (Generator Path) + (do ///////phase.monad + [pattern_matching! (pattern_matching' expression archive pathP)] + (wrap (_.try pattern_matching! + #.None + (#.Some (..catch (_.stop (_.string "Invalid expression for pattern-matching.")))) + #.None)))) + +(def: #export (case expression archive [valueS pathP]) + (Generator [Synthesis Path]) + (do {! ///////phase.monad} + [valueO (expression archive valueS)] + (<| (\ ! map (|>> ($_ _.then + (_.set! $cursor (_.list (list valueO))) + (_.set! $savepoint (_.list (list)))) + _.block)) + (pattern_matching expression archive pathP)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/function.lux new file mode 100644 index 000000000..f30e18def --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/function.lux @@ -0,0 +1,117 @@ +(.module: + [library + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + pipe] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [target + ["_" r (#+ Expression SVar)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] + ["#." case] + ["/#" // #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant Tuple Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["#." generation (#+ Context)] + ["//#" /// #_ + [arity (#+ Arity)] + ["#." phase ("#\." monad)] + [reference + [variable (#+ Register Variable)]] + [meta + [archive + ["." artifact]]]]]]]) + +(def: #export (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do {! ///////phase.monad} + [functionO (expression archive functionS) + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply argsO+ functionO)))) + +(def: (with_closure function_id $function inits function_definition) + (-> artifact.ID SVar (List Expression) Expression (Operation Expression)) + (case inits + #.Nil + (do ///////phase.monad + [_ (/////generation.execute! function_definition) + _ (/////generation.save! (%.nat function_id) + function_definition)] + (wrap $function)) + + _ + (do ///////phase.monad + [#let [closure_definition (_.set! $function + (_.function (|> inits + list.size + list.indices + (list\map //case.capture)) + ($_ _.then + function_definition + $function)))] + _ (/////generation.execute! closure_definition) + _ (/////generation.save! (%.nat function_id) closure_definition)] + (wrap (_.apply inits $function))))) + +(def: $curried (_.var "curried")) +(def: $missing (_.var "missing")) + +(def: (input_declaration register) + (-> Register Expression) + (_.set! (|> register inc //case.register) + (|> $curried (_.nth (|> register inc .int _.int))))) + +(def: #export (function expression archive [environment arity bodyS]) + (Generator (Abstraction Synthesis)) + (do {! ///////phase.monad} + [[[function_module function_artifact] bodyO] (/////generation.with_new_context archive + (do ! + [$self (\ ! map (|>> ///reference.artifact _.var) + (/////generation.context archive))] + (/////generation.with_anchor $self + (expression archive bodyS)))) + closureO+ (monad.map ! (expression archive) environment) + #let [arityO (|> arity .int _.int) + $num_args (_.var "num_args") + $self (_.var (///reference.artifact [function_module function_artifact])) + apply_poly (.function (_ args func) + (_.apply (list func args) (_.var "do.call")))]] + (with_closure function_artifact $self closureO+ + (_.set! $self (_.function (list _.var_args) + ($_ _.then + (_.set! $curried (_.list (list _.var_args))) + (_.set! $num_args (_.length $curried)) + (_.cond (list [(|> $num_args (_.= arityO)) + ($_ _.then + (_.set! (//case.register 0) $self) + (|> arity + list.indices + (list\map input_declaration) + (list\fold _.then bodyO)))] + [(|> $num_args (_.> arityO)) + (let [arity_args (_.slice (_.int +1) arityO $curried) + output_func_args (_.slice (|> arityO (_.+ (_.int +1))) + $num_args + $curried)] + (|> $self + (apply_poly arity_args) + (apply_poly output_func_args)))]) + ## (|> $num_args (_.< arityO)) + (let [$missing (_.var "missing")] + (_.function (list _.var_args) + ($_ _.then + (_.set! $missing (_.list (list _.var_args))) + (|> $self + (apply_poly (_.apply (list $curried $missing) + (_.var "append")))))))))))) + )) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/loop.lux new file mode 100644 index 000000000..f4887aaaa --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/loop.lux @@ -0,0 +1,65 @@ +(.module: + [library + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set (#+ Set)]]] + [math + [number + ["n" nat]]] + [target + ["_" r]]]] + ["." // #_ + [runtime (#+ Operation Phase Generator)] + ["#." case] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + [synthesis + ["." case]] + ["/#" // #_ + ["."synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [meta + [archive (#+ Archive)]] + [reference + [variable (#+ Register)]]]]]]]) + +(def: #export (scope expression archive [offset initsS+ bodyS]) + (Generator (Scope Synthesis)) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [$scope (\ ! map _.var (/////generation.gensym "loop_scope")) + initsO+ (monad.map ! (expression archive) initsS+) + bodyO (/////generation.with_anchor $scope + (expression archive bodyS))] + (wrap (_.block + ($_ _.then + (_.set! $scope + (_.function (|> initsS+ + list.size + list.indices + (list\map (|>> (n.+ offset) //case.register))) + bodyO)) + (_.apply initsO+ $scope))))))) + +(def: #export (recur expression archive argsS+) + (Generator (List Synthesis)) + (do {! ///////phase.monad} + [$scope /////generation.anchor + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply argsO+ $scope)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux new file mode 100644 index 000000000..9b7f40e86 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux @@ -0,0 +1,18 @@ +(.module: + [library + [lux (#- i64) + [target + ["_" r (#+ Expression)]]]] + ["." // #_ + ["#." runtime]]) + +(template [<name> <type> <code>] + [(def: #export <name> + (-> <type> Expression) + <code>)] + + [bit Bit _.bool] + [i64 (I64 Any) (|>> .int //runtime.i64)] + [f64 Frac _.float] + [text Text _.string] + ) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux new file mode 100644 index 000000000..4917eb90f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux @@ -0,0 +1,340 @@ +(.module: + lux + (lux (control [library + [monad #+ do]] + ["ex" exception #+ exception:] + ["p" parser]) + (data ["e" error] + [text] + text/format + [number] + (coll [list "list/" Functor<List>] + (dictionary ["dict" unordered #+ Dict]))) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" lang] + (lang ["la" analysis] + ["ls" synthesis] + (host [r #+ Expression]))) + [///] + (/// [".T" runtime] + [".T" case] + [".T" function] + [".T" loop])) + +## [Types] +(type: #export Translator + (-> ls.Synthesis (Meta Expression))) + +(type: #export Proc + (-> Translator (List ls.Synthesis) (Meta Expression))) + +(type: #export Bundle + (Dict Text Proc)) + +(syntax: (Vector {size s.nat} elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector +0 Expression) Expression)) +(type: #export Unary (-> (Vector +1 Expression) Expression)) +(type: #export Binary (-> (Vector +2 Expression) Expression)) +(type: #export Trinary (-> (Vector +3 Expression) Expression)) +(type: #export Variadic (-> (List Expression) Expression)) + +## [Utils] +(def: #export (install name unnamed) + (-> Text (-> Text Proc) + (-> Bundle Bundle)) + (dict.put name (unnamed name))) + +(def: #export (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + dict.entries + (list/map (function (_ [key val]) [(format prefix " " key) val])) + (dict.from-list text.Hash<Text>))) + +(def: (wrong-arity proc expected actual) + (-> Text Nat Nat Text) + (format "Wrong number of arguments for " (%t proc) "\n" + "Expected: " (|> expected .int %i) "\n" + " Actual: " (|> actual .int %i))) + +(syntax: (arity: {name s.local-identifier} {arity s.nat}) + (with-gensyms [g!_ g!proc g!name g!translate g!inputs] + (do {@ macro.monad} + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!proc)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression) + (-> Text ..Proc)) + (function ((~ g!_) (~ g!name)) + (function ((~ g!_) (~ g!translate) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do macro.Monad<Meta> + [(~+ (|> g!input+ + (list/map (function (_ g!input) + (list g!input (` ((~ g!translate) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) + + (~' _) + (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) + +(arity: nullary +0) +(arity: unary +1) +(arity: binary +2) +(arity: trinary +3) + +(def: #export (variadic proc) + (-> Variadic (-> Text Proc)) + (function (_ proc-name) + (function (_ translate inputsS) + (do {@ macro.Monad<Meta>} + [inputsI (monad.map @ translate inputsS)] + (wrap (proc inputsI)))))) + +## [Procedures] +## [[Lux]] +(def: (lux//is [leftO rightO]) + Binary + (r.apply (list leftO rightO) + (r.global "identical"))) + +(def: (lux//if [testO thenO elseO]) + Trinary + (caseT.translate-if testO thenO elseO)) + +(def: (lux//try riskyO) + Unary + (runtimeT.lux//try riskyO)) + +(exception: #export (Wrong-Syntax {message Text}) + message) + +(def: #export (wrong-syntax procedure args) + (-> Text (List ls.Synthesis) Text) + (format "Procedure: " procedure "\n" + "Arguments: " (%code (code.tuple args)))) + +(def: lux//loop + (-> Text Proc) + (function (_ proc-name) + (function (_ translate inputsS) + (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any)) + (#e.Success [offset initsS+ bodyS]) + (loopT.translate-loop translate offset initsS+ bodyS) + + (#e.Error error) + (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS))) + ))) + +(def: lux//recur + (-> Text Proc) + (function (_ proc-name) + (function (_ translate inputsS) + (loopT.translate-recur translate inputsS)))) + +(def: lux-procs + Bundle + (|> (dict.new text.Hash<Text>) + (install "is" (binary lux//is)) + (install "try" (unary lux//try)) + (install "if" (trinary lux//if)) + (install "loop" lux//loop) + (install "recur" lux//recur) + )) + +## [[Bits]] +(template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [bit//and runtimeT.bit//and] + [bit//or runtimeT.bit//or] + [bit//xor runtimeT.bit//xor] + ) + +(template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> (runtimeT.int64-low paramO) subjectO))] + + [bit//left-shift runtimeT.bit//left-shift] + [bit//arithmetic-right-shift runtimeT.bit//arithmetic-right-shift] + [bit//logical-right-shift runtimeT.bit//logical-right-shift] + ) + +(def: bit-procs + Bundle + (<| (prefix "bit") + (|> (dict.new text.Hash<Text>) + (install "and" (binary bit//and)) + (install "or" (binary bit//or)) + (install "xor" (binary bit//xor)) + (install "left-shift" (binary bit//left-shift)) + (install "logical-right-shift" (binary bit//logical-right-shift)) + (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) + ))) + +## [[Numbers]] +(host.import: java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(template [<name> <const> <encode>] + [(def: (<name> _) + Nullary + (<encode> <const>))] + + [frac//smallest Double::MIN_VALUE r.float] + [frac//min (f/* -1.0 Double::MAX_VALUE) r.float] + [frac//max Double::MAX_VALUE r.float] + ) + +(template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (|> subjectO (<op> paramO)))] + + [int//add runtimeT.int//+] + [int//sub runtimeT.int//-] + [int//mul runtimeT.int//*] + [int//div runtimeT.int///] + [int//rem runtimeT.int//%] + ) + +(template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [frac//add r.+] + [frac//sub r.-] + [frac//mul r.*] + [frac//div r./] + [frac//rem r.%%] + [frac//= r.=] + [frac//< r.<] + + [text//= r.=] + [text//< r.<] + ) + +(template [<name> <cmp>] + [(def: (<name> [subjectO paramO]) + Binary + (<cmp> paramO subjectO))] + + [int//= runtimeT.int//=] + [int//< runtimeT.int//<] + ) + +(def: (apply1 func) + (-> Expression (-> Expression Expression)) + (function (_ value) + (r.apply (list value) func))) + +(def: int//char (|>> runtimeT.int64-low (apply1 (r.global "intToUtf8")))) + +(def: int-procs + Bundle + (<| (prefix "int") + (|> (dict.new text.Hash<Text>) + (install "+" (binary int//add)) + (install "-" (binary int//sub)) + (install "*" (binary int//mul)) + (install "/" (binary int//div)) + (install "%" (binary int//rem)) + (install "=" (binary int//=)) + (install "<" (binary int//<)) + (install "to-frac" (unary runtimeT.int//to-float)) + (install "char" (unary int//char))))) + +(def: (frac//encode value) + (-> Expression Expression) + (r.apply (list (r.string "%f") value) (r.global "sprintf"))) + +(def: frac-procs + Bundle + (<| (prefix "frac") + (|> (dict.new text.Hash<Text>) + (install "+" (binary frac//add)) + (install "-" (binary frac//sub)) + (install "*" (binary frac//mul)) + (install "/" (binary frac//div)) + (install "%" (binary frac//rem)) + (install "=" (binary frac//=)) + (install "<" (binary frac//<)) + (install "smallest" (nullary frac//smallest)) + (install "min" (nullary frac//min)) + (install "max" (nullary frac//max)) + (install "to-int" (unary (apply1 (r.global "as.integer")))) + (install "encode" (unary frac//encode)) + (install "decode" (unary runtimeT.frac//decode))))) + +## [[Text]] +(def: (text//concat [subjectO paramO]) + Binary + (r.apply (list subjectO paramO) (r.global "paste0"))) + +(def: (text//char [subjectO paramO]) + Binary + (runtimeT.text//char subjectO paramO)) + +(def: (text//clip [subjectO paramO extraO]) + Trinary + (runtimeT.text//clip subjectO paramO extraO)) + +(def: (text//index [textO partO startO]) + Trinary + (runtimeT.text//index textO partO startO)) + +(def: text-procs + Bundle + (<| (prefix "text") + (|> (dict.new text.Hash<Text>) + (install "=" (binary text//=)) + (install "<" (binary text//<)) + (install "concat" (binary text//concat)) + (install "index" (trinary text//index)) + (install "size" (unary (|>> (apply1 (r.global "nchar")) runtimeT.int//from-float))) + (install "char" (binary text//char)) + (install "clip" (trinary text//clip)) + ))) + +## [[IO]] +(def: (io//exit input) + Unary + (r.apply-kw (list) + (list ["status" (runtimeT.int//to-float input)]) + (r.global "quit"))) + +(def: (void code) + (-> Expression Expression) + (r.block (r.then code runtimeT.unit))) + +(def: io-procs + Bundle + (<| (prefix "io") + (|> (dict.new text.Hash<Text>) + (install "log" (unary (|>> r.print ..void))) + (install "error" (unary r.stop)) + (install "exit" (unary io//exit)) + (install "current-time" (nullary (function (_ _) + (runtimeT.io//current-time! runtimeT.unit))))))) + +## [Bundles] +(def: #export procedures + Bundle + (<| (prefix "lux") + (|> lux-procs + (dict.merge bit-procs) + (dict.merge int-procs) + (dict.merge frac-procs) + (dict.merge text-procs) + (dict.merge io-procs) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux new file mode 100644 index 000000000..5dabf7f2a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux @@ -0,0 +1,90 @@ +(.module: + lux + (lux (control [library + [monad #+ do]]) + (data [text] + text/format + (coll [list "list/" Functor<List>] + (dictionary ["dict" unordered #+ Dict]))) + [macro "macro/" Monad<Meta>]) + (luxc ["&" lang] + (lang ["la" analysis] + ["ls" synthesis] + (host [ruby #+ Ruby Expression Statement]))) + [///] + (/// [".T" runtime]) + (// ["@" common])) + +## (template [<name> <lua>] +## [(def: (<name> _) @.Nullary <lua>)] + +## [lua//nil "nil"] +## [lua//table "{}"] +## ) + +## (def: (lua//global proc translate inputs) +## (-> Text @.Proc) +## (case inputs +## (^ (list [_ (#.Text name)])) +## (do macro.Monad<Meta> +## [] +## (wrap name)) + +## _ +## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +## (def: (lua//call proc translate inputs) +## (-> Text @.Proc) +## (case inputs +## (^ (list& functionS argsS+)) +## (do {@ macro.Monad<Meta>} +## [functionO (translate functionS) +## argsO+ (monad.map @ translate argsS+)] +## (wrap (lua.apply functionO argsO+))) + +## _ +## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +## (def: lua-procs +## @.Bundle +## (|> (dict.new text.Hash<Text>) +## (@.install "nil" (@.nullary lua//nil)) +## (@.install "table" (@.nullary lua//table)) +## (@.install "global" lua//global) +## (@.install "call" lua//call))) + +## (def: (table//call proc translate inputs) +## (-> Text @.Proc) +## (case inputs +## (^ (list& tableS [_ (#.Text field)] argsS+)) +## (do {@ macro.Monad<Meta>} +## [tableO (translate tableS) +## argsO+ (monad.map @ translate argsS+)] +## (wrap (lua.method field tableO argsO+))) + +## _ +## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +## (def: (table//get [fieldO tableO]) +## @.Binary +## (runtimeT.lua//get tableO fieldO)) + +## (def: (table//set [fieldO valueO tableO]) +## @.Trinary +## (runtimeT.lua//set tableO fieldO valueO)) + +## (def: table-procs +## @.Bundle +## (<| (@.prefix "table") +## (|> (dict.new text.Hash<Text>) +## (@.install "call" table//call) +## (@.install "get" (@.binary table//get)) +## (@.install "set" (@.trinary table//set))))) + +(def: #export procedures + @.Bundle + (<| (@.prefix "lua") + (dict.new text.Hash<Text>) + ## (|> lua-procs + ## (dict.merge table-procs)) + )) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/reference.lux new file mode 100644 index 000000000..bbdb06ba0 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" r (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System Expression) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux new file mode 100644 index 000000000..4682a593d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux @@ -0,0 +1,855 @@ +(.module: + [library + [lux (#- Location inc i64) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<.>" code]]] + [data + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." list ("#\." functor)] + ["." row]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["n" nat] + ["i" int ("#\." interval)] + ["." i64]]] + ["@" target + ["_" r (#+ SVar Expression)]]]] + ["." /// #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant)] + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// + ["#." phase] + [reference + [variable (#+ Register)]] + [meta + [archive (#+ Output Archive) + ["." artifact (#+ Registry)]]]]]]) + +(def: module_id + 0) + +(template [<name> <base>] + [(type: #export <name> + (<base> _.SVar _.Expression _.Expression))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type: #export (Generator i) + (-> Phase Archive i (Operation Expression))) + +(def: #export unit + Expression + (_.string /////synthesis.unit)) + +(def: full_32 (hex "FFFFFFFF")) +(def: half_32 (hex "7FFFFFFF")) +(def: post_32 (hex "100000000")) + +(def: (cap_32 input) + (-> Nat Int) + (cond (n.> full_32 input) + (|> input (i64.and full_32) cap_32) + + (n.> half_32 input) + (|> post_32 (n.- input) .int (i.* -1)) + + ## else + (.int input))) + +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} + body) + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} + code) + (do meta.monad + [runtime_id meta.count] + (macro.with_gensyms [g!_] + (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.var (~ (code.text (%.code runtime)))))] + (case declaration + (#.Left name) + (let [g!name (code.local_identifier name)] + (wrap (list (` (def: #export (~ g!name) + _.SVar + (~ runtime_name))) + + (` (def: (~ (code.local_identifier (format "@" name))) + _.Expression + (_.set! (~ runtime_name) (~ code))))))) + + (#.Right [name inputs]) + (let [g!name (code.local_identifier name) + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` _.Expression)) + inputs)] + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) + (-> (~+ inputs_typesC) _.Expression) + (_.apply (list (~+ inputsC)) (~ runtime_name)))) + + (` (def: (~ (code.local_identifier (format "@" name))) + _.Expression + (..with_vars [(~+ inputsC)] + (_.set! (~ runtime_name) + (_.function (list (~+ inputsC)) + (~ code)))))))))))))) + +(def: #export variant_tag_field "luxVT") +(def: #export variant_flag_field "luxVF") +(def: #export variant_value_field "luxVV") + +(def: #export (flag value) + (-> Bit Expression) + (if value + (_.string "") + _.null)) + +(runtime: (adt::variant tag last? value) + (_.named_list (list [..variant_tag_field (_.as::integer tag)] + [..variant_flag_field last?] + [..variant_value_field value]))) + +(def: #export (variant tag last? value) + (-> Nat Bit Expression Expression) + (adt::variant (_.int (.int tag)) + (flag last?) + value)) + +(def: #export none + Expression + (variant 0 #0 ..unit)) + +(def: #export some + (-> Expression Expression) + (variant 1 #1)) + +(def: #export left + (-> Expression Expression) + (variant 0 #0)) + +(def: #export right + (-> Expression Expression) + (variant 1 #1)) + +(def: high_shift (_.bit_shl (_.int +32))) + +(template [<name> <power>] + [(runtime: <name> (|> (_.as::integer (_.int +2)) (_.** (_.as::integer (_.int <power>)))))] + + [f2^32 +32] + [f2^63 +63] + ) + +(def: (as_double value) + (-> Expression Expression) + (_.apply (list value) (_.var "as.double"))) + +(def: #export i64_high_field "luxIH") +(def: #export i64_low_field "luxIL") + +(runtime: (i64::unsigned_low input) + (with_vars [low] + ($_ _.then + (_.set! low (|> input (_.nth (_.string ..i64_low_field)))) + (_.if (|> low (_.>= (_.int +0))) + low + (|> low (_.+ f2^32)))))) + +(runtime: (i64::to_float input) + (let [high (|> input + (_.nth (_.string ..i64_high_field)) + high_shift) + low (|> input + i64::unsigned_low)] + (|> high (_.+ low) as_double))) + +(runtime: (i64::new high low) + (_.named_list (list [..i64_high_field (_.as::integer high)] + [..i64_low_field (_.as::integer low)]))) + +(def: high_32 + (-> Nat Nat) + (i64.right_shift 32)) + +(def: low_32 + (-> Nat Nat) + (|>> (i64.and (hex "FFFFFFFF")))) + +(def: #export (i64 value) + (-> Int Expression) + (let [value (.nat value)] + (i64::new (|> value ..high_32 ..cap_32 _.int) + (|> value ..low_32 ..cap_32 _.int)))) + +(def: #export (lux_i64 high low) + (-> Int Int Int) + (|> high + (i64.left_shift 32) + (i64.or low))) + +(template [<name> <value>] + [(runtime: <name> + (..i64 <value>))] + + [i64::zero +0] + [i64::one +1] + [i64::min i\bottom] + [i64::max i\top] + ) + +(def: #export i64_high (_.nth (_.string ..i64_high_field))) +(def: #export i64_low (_.nth (_.string ..i64_low_field))) + +(runtime: (i64::not input) + (i64::new (|> input i64_high _.bit_not) + (|> input i64_low _.bit_not))) + +(runtime: (i64::+ param subject) + (with_vars [sH sL pH pL + x00 x16 x32 x48] + ($_ _.then + (_.set! sH (|> subject i64_high)) + (_.set! sL (|> subject i64_low)) + (_.set! pH (|> param i64_high)) + (_.set! pL (|> param i64_low)) + (let [bits16 (_.manual "0xFFFF") + move_top_16 (_.bit_shl (_.int +16)) + top_16 (_.bit_ushr (_.int +16)) + bottom_16 (_.bit_and bits16) + split_16 (function (_ source) + [(|> source top_16) + (|> source bottom_16)]) + split_int (function (_ high low) + [(split_16 high) + (split_16 low)]) + + [[s48 s32] [s16 s00]] (split_int sH sL) + [[p48 p32] [p16 p00]] (split_int pH pL) + new_half (function (_ top bottom) + (|> top bottom_16 move_top_16 + (_.bit_or (bottom_16 bottom))))] + ($_ _.then + (_.set! x00 (|> s00 (_.+ p00))) + (_.set! x16 (|> x00 top_16 (_.+ s16) (_.+ p16))) + (_.set! x32 (|> x16 top_16 (_.+ s32) (_.+ p32))) + (_.set! x48 (|> x32 top_16 (_.+ s48) (_.+ p48))) + (i64::new (new_half x48 x32) + (new_half x16 x00))))))) + +(runtime: (i64::= reference sample) + (let [n/a? (function (_ value) + (_.apply (list value) (_.var "is.na"))) + isTRUE? (function (_ value) + (_.apply (list value) (_.var "isTRUE"))) + comparison (: (-> (-> Expression Expression) Expression) + (function (_ field) + (|> (|> (field sample) (_.= (field reference))) + (_.or (|> (n/a? (field sample)) + (_.and (n/a? (field reference))))))))] + (|> (comparison i64_high) + (_.and (comparison i64_low)) + isTRUE?))) + +(runtime: (i64::negate input) + (_.if (|> input (i64::= i64::min)) + i64::min + (|> input i64::not (i64::+ i64::one)))) + +(runtime: i64::-one + (i64::negate i64::one)) + +(runtime: (i64::- param subject) + (i64::+ (i64::negate param) subject)) + +(runtime: (i64::< reference sample) + (with_vars [r_? s_?] + ($_ _.then + (_.set! s_? (|> sample ..i64_high (_.< (_.int +0)))) + (_.set! r_? (|> reference ..i64_high (_.< (_.int +0)))) + (|> (|> s_? (_.and (_.not r_?))) + (_.or (|> (_.not s_?) (_.and r_?) _.not)) + (_.or (|> sample + (i64::- reference) + ..i64_high + (_.< (_.int +0)))))))) + +(runtime: (i64::from_float input) + (_.cond (list [(_.apply (list input) (_.var "is.nan")) + i64::zero] + [(|> input (_.<= (_.negate f2^63))) + i64::min] + [(|> input (_.+ (_.float +1.0)) (_.>= f2^63)) + i64::max] + [(|> input (_.< (_.float +0.0))) + (|> input _.negate i64::from_float i64::negate)]) + (i64::new (|> input (_./ f2^32)) + (|> input (_.%% f2^32))))) + +(runtime: (i64::* param subject) + (with_vars [sH sL pH pL + x00 x16 x32 x48] + ($_ _.then + (_.set! sH (|> subject i64_high)) + (_.set! pH (|> param i64_high)) + (let [negative_subject? (|> sH (_.< (_.int +0))) + negative_param? (|> pH (_.< (_.int +0)))] + (_.cond (list [negative_subject? + (_.if negative_param? + (i64::* (i64::negate param) + (i64::negate subject)) + (i64::negate (i64::* param + (i64::negate subject))))] + + [negative_param? + (i64::negate (i64::* (i64::negate param) + subject))]) + ($_ _.then + (_.set! sL (|> subject i64_low)) + (_.set! pL (|> param i64_low)) + (let [bits16 (_.manual "0xFFFF") + move_top_16 (_.bit_shl (_.int +16)) + top_16 (_.bit_ushr (_.int +16)) + bottom_16 (_.bit_and bits16) + split_16 (function (_ source) + [(|> source top_16) + (|> source bottom_16)]) + split_int (function (_ high low) + [(split_16 high) + (split_16 low)]) + new_half (function (_ top bottom) + (|> top bottom_16 move_top_16 + (_.bit_or (bottom_16 bottom)))) + x16_top (|> x16 top_16) + x32_top (|> x32 top_16)] + (with_vars [s48 s32 s16 s00 + p48 p32 p16 p00] + (let [[[_s48 _s32] [_s16 _s00]] (split_int sH sL) + [[_p48 _p32] [_p16 _p00]] (split_int pH pL) + set_subject_chunks! ($_ _.then (_.set! s48 _s48) (_.set! s32 _s32) (_.set! s16 _s16) (_.set! s00 _s00)) + set_param_chunks! ($_ _.then (_.set! p48 _p48) (_.set! p32 _p32) (_.set! p16 _p16) (_.set! p00 _p00))] + ($_ _.then + set_subject_chunks! + set_param_chunks! + (_.set! x00 (|> s00 (_.* p00))) + (_.set! x16 (|> x00 top_16 (_.+ (|> s16 (_.* p00))))) + (_.set! x32 x16_top) + (_.set! x16 (|> x16 bottom_16 (_.+ (|> s00 (_.* p16))))) + (_.set! x32 (|> x32 (_.+ x16_top) (_.+ (|> s32 (_.* p00))))) + (_.set! x48 x32_top) + (_.set! x32 (|> x32 bottom_16 (_.+ (|> s16 (_.* p16))))) + (_.set! x48 (|> x48 (_.+ x32_top))) + (_.set! x32 (|> x32 bottom_16 (_.+ (|> s00 (_.* p32))))) + (_.set! x48 (|> x48 (_.+ x32_top) + (_.+ (|> s48 (_.* p00))) + (_.+ (|> s32 (_.* p16))) + (_.+ (|> s16 (_.* p32))) + (_.+ (|> s00 (_.* p48))))) + (i64::new (new_half x48 x32) + (new_half x16 x00))))) + ))))))) + +(def: (limit_shift! shift) + (-> SVar Expression) + (_.set! shift (|> shift (_.bit_and (_.as::integer (_.int +63)))))) + +(def: (no_shift_clause shift input) + (-> SVar SVar [Expression Expression]) + [(|> shift (_.= (_.int +0))) + input]) + +(runtime: (i64::left_shift shift input) + ($_ _.then + (limit_shift! shift) + (_.cond (list (no_shift_clause shift input) + [(|> shift (_.< (_.int +32))) + (let [mid (|> (i64_low input) (_.bit_ushr (|> (_.int +32) (_.- shift)))) + high (|> (i64_high input) + (_.bit_shl shift) + (_.bit_or mid)) + low (|> (i64_low input) + (_.bit_shl shift))] + (i64::new high low))]) + (let [high (|> (i64_high input) + (_.bit_shl (|> shift (_.- (_.int +32)))))] + (i64::new high (_.int +0)))))) + +(runtime: (i64::arithmetic_right_shift_32 shift input) + (let [top_bit (|> input (_.bit_and (_.as::integer (_.int (hex "+80000000")))))] + (|> input + (_.bit_ushr shift) + (_.bit_or top_bit)))) + +(runtime: (i64::arithmetic_right_shift shift input) + ($_ _.then + (limit_shift! shift) + (_.cond (list (no_shift_clause shift input) + [(|> shift (_.< (_.int +32))) + (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift)))) + high (|> (i64_high input) + (i64::arithmetic_right_shift_32 shift)) + low (|> (i64_low input) + (_.bit_ushr shift) + (_.bit_or mid))] + (i64::new high low))]) + (let [low (|> (i64_high input) + (i64::arithmetic_right_shift_32 (|> shift (_.- (_.int +32))))) + high (_.if (|> (i64_high input) (_.>= (_.int +0))) + (_.int +0) + (_.int -1))] + (i64::new high low))))) + +(runtime: (i64::/ param subject) + (let [negative? (|>> (i64::< i64::zero)) + valid_division_check [(|> param (i64::= i64::zero)) + (_.stop (_.string "Cannot divide by zero!"))] + short_circuit_check [(|> subject (i64::= i64::zero)) + i64::zero]] + (_.cond (list valid_division_check + short_circuit_check + + [(|> subject (i64::= i64::min)) + (_.cond (list [(|> (|> param (i64::= i64::one)) + (_.or (|> param (i64::= i64::-one)))) + i64::min] + [(|> param (i64::= i64::min)) + i64::one]) + (with_vars [approximation] + ($_ _.then + (_.set! approximation + (|> subject + (i64::arithmetic_right_shift (_.int +1)) + (i64::/ param) + (i64::left_shift (_.int +1)))) + (_.if (|> approximation (i64::= i64::zero)) + (_.if (negative? param) + i64::one + i64::-one) + (let [remainder (i64::- (i64::* param approximation) + subject)] + (|> remainder + (i64::/ param) + (i64::+ approximation)))))))] + [(|> param (i64::= i64::min)) + i64::zero] + + [(negative? subject) + (_.if (negative? param) + (|> (i64::negate subject) + (i64::/ (i64::negate param))) + (|> (i64::negate subject) + (i64::/ param) + i64::negate))] + + [(negative? param) + (|> param + i64::negate + (i64::/ subject) + i64::negate)]) + (with_vars [result remainder approximate approximate_result log2 approximate_remainder] + ($_ _.then + (_.set! result i64::zero) + (_.set! remainder subject) + (_.while (|> (|> remainder (i64::< param)) + (_.or (|> remainder (i64::= param)))) + (let [calc_rough_estimate (_.apply (list (|> (i64::to_float remainder) (_./ (i64::to_float param)))) + (_.var "floor")) + calc_approximate_result (i64::from_float approximate) + calc_approximate_remainder (|> approximate_result (i64::* param)) + delta (_.if (|> (_.float +48.0) (_.<= log2)) + (_.float +1.0) + (_.** (|> log2 (_.- (_.float +48.0))) + (_.float +2.0)))] + ($_ _.then + (_.set! approximate (_.apply (list (_.float +1.0) calc_rough_estimate) + (_.var "max"))) + (_.set! log2 (let [log (function (_ input) + (_.apply (list input) (_.var "log")))] + (_.apply (list (|> (log (_.int +2)) + (_./ (log approximate)))) + (_.var "ceil")))) + (_.set! approximate_result calc_approximate_result) + (_.set! approximate_remainder calc_approximate_remainder) + (_.while (|> (negative? approximate_remainder) + (_.or (|> approximate_remainder (i64::< remainder)))) + ($_ _.then + (_.set! approximate (|> delta (_.- approximate))) + (_.set! approximate_result calc_approximate_result) + (_.set! approximate_remainder calc_approximate_remainder))) + (_.set! result (|> (_.if (|> approximate_result (i64::= i64::zero)) + i64::one + approximate_result) + (i64::+ result))) + (_.set! remainder (|> remainder (i64::- approximate_remainder)))))) + result)) + ))) + +(runtime: (i64::% param subject) + (let [flat (|> subject (i64::/ param) (i64::* param))] + (|> subject (i64::- flat)))) + +(runtime: (lux::try op) + (with_vars [error value] + (_.try ($_ _.then + (_.set! value (_.apply (list ..unit) op)) + (..right value)) + #.None + (#.Some (_.function (list error) + (..left (_.nth (_.string "message") + error)))) + #.None))) + +(runtime: (lux::program_args program_args) + (with_vars [inputs value] + ($_ _.then + (_.set! inputs ..none) + (<| (_.for_in value program_args) + (_.set! inputs (..some (_.list (list value inputs))))) + inputs))) + +(def: runtime::lux + Expression + ($_ _.then + @lux::try + @lux::program_args + )) + +(def: current_time_float + Expression + (let [raw_time (_.apply (list) (_.var "Sys.time"))] + (_.apply (list raw_time) (_.var "as.numeric")))) + +(runtime: (io::current_time! _) + (|> current_time_float + (_.* (_.float +1,000.0)) + i64::from_float)) + +(def: runtime::io + Expression + ($_ _.then + @io::current_time! + )) + +(def: minimum_index_length + (-> SVar Expression) + (|>> (_.+ (_.int +1)))) + +(def: (product_element product index) + (-> Expression Expression Expression) + (|> product (_.nth (|> index (_.+ (_.int +1)))))) + +(def: (product_tail product) + (-> SVar Expression) + (|> product (_.nth (_.length product)))) + +(def: (updated_index min_length product) + (-> Expression Expression Expression) + (|> min_length (_.- (_.length product)))) + +(runtime: (tuple::left index product) + (let [$index_min_length (_.var "index_min_length")] + ($_ _.then + (_.set! $index_min_length (minimum_index_length index)) + (_.if (|> (_.length product) (_.> $index_min_length)) + ## No need for recursion + (product_element product index) + ## Needs recursion + (tuple::left (updated_index $index_min_length product) + (product_tail product)))))) + +(runtime: (tuple::right index product) + (let [$index_min_length (_.var "index_min_length")] + ($_ _.then + (_.set! $index_min_length (minimum_index_length index)) + (_.cond (list [## Last element. + (|> (_.length product) (_.= $index_min_length)) + (product_element product index)] + [## Needs recursion + (|> (_.length product) (_.< $index_min_length)) + (tuple::right (updated_index $index_min_length product) + (product_tail product))]) + ## Must slice + (|> product (_.slice_from index)))))) + +(runtime: (sum::get sum wants_last? wanted_tag) + (let [no_match _.null + sum_tag (|> sum (_.nth (_.string ..variant_tag_field))) + sum_flag (|> sum (_.nth (_.string ..variant_flag_field))) + sum_value (|> sum (_.nth (_.string ..variant_value_field))) + is_last? (|> sum_flag (_.= (_.string ""))) + test_recursion (_.if is_last? + ## Must recurse. + (|> wanted_tag + (_.- sum_tag) + (sum::get sum_value wants_last?)) + no_match)] + (_.cond (list [(_.= sum_tag wanted_tag) + (_.if (_.= wants_last? sum_flag) + sum_value + test_recursion)] + + [(|> wanted_tag (_.> sum_tag)) + test_recursion] + + [(|> (|> wants_last? (_.= (_.string ""))) + (_.and (|> wanted_tag (_.< sum_tag)))) + (adt::variant (|> sum_tag (_.- wanted_tag)) sum_flag sum_value)]) + + no_match))) + +(def: runtime::adt + Expression + ($_ _.then + @tuple::left + @tuple::right + @sum::get + @adt::variant + )) + +(template [<name> <op>] + [(runtime: (<name> mask input) + (i64::new (<op> (i64_high mask) + (i64_high input)) + (<op> (i64_low mask) + (i64_low input))))] + + [i64::and _.bit_and] + [i64::or _.bit_or] + [i64::xor _.bit_xor] + ) + +(runtime: (i64::right_shift shift input) + ($_ _.then + (limit_shift! shift) + (_.cond (list (no_shift_clause shift input) + [(|> shift (_.< (_.int +32))) + (with_vars [$mid] + (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift)))) + high (|> (i64_high input) (_.bit_ushr shift)) + low (|> (i64_low input) + (_.bit_ushr shift) + (_.bit_or (_.if (_.apply (list $mid) (_.var "is.na")) + (_.as::integer (_.int +0)) + $mid)))] + ($_ _.then + (_.set! $mid mid) + (i64::new high low))))] + [(|> shift (_.= (_.int +32))) + (let [high (i64_high input)] + (i64::new (_.int +0) high))]) + (let [low (|> (i64_high input) (_.bit_ushr (|> shift (_.- (_.int +32)))))] + (i64::new (_.int +0) low))))) + +(def: runtime::i64 + Expression + ($_ _.then + @f2^32 + @f2^63 + + @i64::new + @i64::from_float + + @i64::and + @i64::or + @i64::xor + @i64::not + @i64::left_shift + @i64::arithmetic_right_shift_32 + @i64::arithmetic_right_shift + @i64::right_shift + + @i64::zero + @i64::one + @i64::min + @i64::max + @i64::= + @i64::< + @i64::+ + @i64::- + @i64::negate + @i64::-one + @i64::unsigned_low + @i64::to_float + @i64::* + @i64::/ + @i64::% + )) + +(runtime: (frac::decode input) + (with_vars [output] + ($_ _.then + (_.set! output (_.apply (list input) (_.var "as.numeric"))) + (_.if (|> output (_.= _.n/a)) + ..none + (..some output))))) + +(def: runtime::frac + Expression + ($_ _.then + @frac::decode + )) + +(def: inc + (-> Expression Expression) + (|>> (_.+ (_.int +1)))) + +(template [<name> <top_cmp>] + [(def: (<name> top value) + (-> Expression Expression Expression) + (|> (|> value (_.>= (_.int +0))) + (_.and (|> value (<top_cmp> top)))))] + + [within? _.<] + [up_to? _.<=] + ) + +(def: (text_clip start end text) + (-> Expression Expression Expression Expression) + (_.apply (list text start end) + (_.var "substr"))) + +(def: (text_length text) + (-> Expression Expression) + (_.apply (list text) (_.var "nchar"))) + +(runtime: (text::index subject param start) + (with_vars [idx startF subjectL] + ($_ _.then + (_.set! startF (i64::to_float start)) + (_.set! subjectL (text_length subject)) + (_.if (|> startF (within? subjectL)) + ($_ _.then + (_.set! idx (|> (_.apply_kw (list param (_.if (|> startF (_.= (_.int +0))) + subject + (text_clip (inc startF) + (inc subjectL) + subject))) + (list ["fixed" (_.bool #1)]) + (_.var "regexpr")) + (_.nth (_.int +1)))) + (_.if (|> idx (_.= (_.int -1))) + ..none + (..some (i64::from_float (|> idx (_.+ startF)))))) + ..none)))) + +(runtime: (text::clip text from to) + (with_vars [length] + ($_ _.then + (_.set! length (_.length text)) + (_.if ($_ _.and + (|> to (within? length)) + (|> from (up_to? to))) + (..some (text_clip (inc from) (inc to) text)) + ..none)))) + +(def: (char_at idx text) + (-> Expression Expression Expression) + (_.apply (list (text_clip idx idx text)) + (_.var "utf8ToInt"))) + +(runtime: (text::char text idx) + (_.if (|> idx (within? (_.length text))) + ($_ _.then + (_.set! idx (inc idx)) + (..some (i64::from_float (char_at idx text)))) + ..none)) + +(def: runtime::text + Expression + ($_ _.then + @text::index + @text::clip + @text::char + )) + +(def: (check_index_out_of_bounds array idx body) + (-> Expression Expression Expression Expression) + (_.if (|> idx (_.<= (_.length array))) + body + (_.stop (_.string "Array index out of bounds!")))) + +(runtime: (array::new size) + (with_vars [output] + ($_ _.then + (_.set! output (_.list (list))) + (_.set_nth! (|> size (_.+ (_.int +1))) + _.null + output) + output))) + +(runtime: (array::get array idx) + (with_vars [temp] + (<| (check_index_out_of_bounds array idx) + ($_ _.then + (_.set! temp (|> array (_.nth (_.+ (_.int +1) idx)))) + (_.if (|> temp (_.= _.null)) + ..none + (..some temp)))))) + +(runtime: (array::put array idx value) + (<| (check_index_out_of_bounds array idx) + ($_ _.then + (_.set_nth! (_.+ (_.int +1) idx) value array) + array))) + +(def: runtime::array + Expression + ($_ _.then + @array::new + @array::get + @array::put + )) + +(def: runtime + Expression + ($_ _.then + runtime::lux + runtime::i64 + runtime::adt + runtime::frac + runtime::text + runtime::array + runtime::io + )) + +(def: #export generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! (%.nat ..module_id) ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row [(%.nat ..module_id) + (|> ..runtime + _.code + (\ utf8.codec encode))])]))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/structure.lux new file mode 100644 index 000000000..1020cad97 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/structure.lux @@ -0,0 +1,40 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [data + [collection + ["." list]]] + [target + ["_" r (#+ Expression)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." primitive] + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + ["//#" /// #_ + ["#." phase ("#\." monad)]]]]) + +(def: #export (tuple expression archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + #.Nil + (///////phase\wrap (//primitive.text /////synthesis.unit)) + + (#.Cons singletonS #.Nil) + (expression archive singletonS) + + _ + (|> elemsS+ + (monad.map ///////phase.monad (expression archive)) + (///////phase\map _.list)))) + +(def: #export (variant expression archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (inc lefts) + lefts)] + (///////phase\map (|>> (//runtime.variant tag right?)) + (expression archive valueS)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/reference.lux new file mode 100644 index 000000000..8b2a907ca --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/reference.lux @@ -0,0 +1,89 @@ +(.module: + [library + [lux #* + ["@" target] + [data + [text + ["%" format (#+ format)]]]]] + ["." //// #_ + ["." version] + ["#." generation (#+ Context)] + ["//#" /// #_ + ["." reference (#+ Reference) + ["." variable (#+ Register Variable)]] + ["." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]) + +## This universe constant is for languages where one can't just turn all compiled definitions +## into the local variables of some scoping function. +(def: #export universe + (for {## In the case of Lua, there is a limit of 200 locals in a function's scope. + @.lua (not ("lua script universe")) + ## Cannot make all definitions be local variables because of limitations with JRuby. + @.ruby (not ("ruby script universe")) + ## Cannot make all definitions be local variables because of limitations with PHP itself. + @.php (not ("php script universe")) + ## Cannot make all definitions be local variables because of limitations with Kawa. + @.scheme (not ("scheme script universe"))} + #0)) + +(def: universe_label + Text + (with_expansions [<label> (format "u" (%.nat (if ..universe 1 0)))] + (for {@.lua <label> + @.ruby <label> + @.php <label> + @.scheme <label>} + ""))) + +(def: #export (artifact [module artifact]) + (-> Context Text) + (format "l" (%.nat version.version) + ..universe_label + "m" (%.nat module) + "a" (%.nat artifact))) + +(interface: #export (System expression) + (: (-> Text expression) + constant) + (: (-> Text expression) + variable)) + +(def: #export (constant system archive name) + (All [anchor expression directive] + (-> (System expression) Archive Name + (////generation.Operation anchor expression directive expression))) + (phase\map (|>> ..artifact (\ system constant)) + (////generation.remember archive name))) + +(template [<sigil> <name>] + [(def: #export (<name> system) + (All [expression] + (-> (System expression) + (-> Register expression))) + (|>> %.nat (format <sigil>) (\ system variable)))] + + ["f" foreign] + ["l" local] + ) + +(def: #export (variable system variable) + (All [expression] + (-> (System expression) Variable expression)) + (case variable + (#variable.Local register) + (..local system register) + + (#variable.Foreign register) + (..foreign system register))) + +(def: #export (reference system archive reference) + (All [anchor expression directive] + (-> (System expression) Archive Reference (////generation.Operation anchor expression directive expression))) + (case reference + (#reference.Constant value) + (..constant system archive value) + + (#reference.Variable value) + (phase\wrap (..variable system value)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby.lux new file mode 100644 index 000000000..c891727e4 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby.lux @@ -0,0 +1,105 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." exception (#+ exception:)]] + [target + ["_" ruby]]]] + ["." / #_ + [runtime (#+ Phase Phase!)] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." function] + ["#." case] + ["#." loop] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + [analysis (#+)] + ["#." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) + +(def: (statement expression archive synthesis) + Phase! + (case synthesis + (^template [<tag>] + [(^ (<tag> value)) + (//////phase\map _.return (expression archive synthesis))]) + ([////synthesis.bit] + [////synthesis.i64] + [////synthesis.f64] + [////synthesis.text] + [////synthesis.variant] + [////synthesis.tuple] + [#////synthesis.Reference] + [////synthesis.branch/get] + [////synthesis.function/apply] + [#////synthesis.Extension]) + + (^ (////synthesis.branch/case case)) + (/case.case! false statement expression archive case) + + (^template [<tag> <generator>] + [(^ (<tag> value)) + (<generator> statement expression archive value)]) + ([////synthesis.branch/let /case.let!] + [////synthesis.branch/if /case.if!] + [////synthesis.loop/scope /loop.scope!] + [////synthesis.loop/recur /loop.recur!]) + + (^ (////synthesis.function/abstraction abstraction)) + (//////phase\map _.return (/function.function statement expression archive abstraction)) + )) + +(exception: #export cannot-recur-as-an-expression) + +(def: (expression archive synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + [(^ (<tag> value)) + (//////phase\wrap (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + (^template [<tag> <generator>] + [(^ (<tag> value)) + (<generator> expression archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + + [////synthesis.function/apply /function.apply]) + + (^template [<tag> <generator>] + [(^ (<tag> value)) + (<generator> statement expression archive value)]) + ([////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.function/abstraction /function.function]) + + (^ (////synthesis.loop/recur _)) + (//////phase.throw ..cannot-recur-as-an-expression []) + + (#////synthesis.Reference value) + (//reference.reference /reference.system archive value) + + (#////synthesis.Extension extension) + (///extension.apply archive expression extension))) + +(def: #export generate + Phase + ..expression) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux new file mode 100644 index 000000000..3c080ba8a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux @@ -0,0 +1,360 @@ +(.module: + [library + [lux (#- case let if) + [abstract + ["." monad (#+ do)]] + [control + [exception (#+ exception:)]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set]]] + [math + [number + ["n" nat] + ["i" int]]] + [target + ["_" ruby (#+ Expression LVar Statement)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator Phase! Generator!)] + ["#." reference] + ["#." primitive] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + [synthesis + ["." case]] + ["/#" // #_ + ["#." synthesis (#+ Member Synthesis Path)] + ["#." generation] + ["//#" /// #_ + [reference + ["#." variable (#+ Register)]] + ["#." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]]) + +(def: #export (gensym prefix) + (-> Text (Operation LVar)) + (///////phase\map (|>> %.nat (format prefix) _.local) /////generation.next)) + +(def: #export register + (-> Register LVar) + (|>> (///reference.local //reference.system) :assume)) + +(def: #export capture + (-> Register LVar) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: #export (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + ## TODO: Find some way to do 'let' without paying the price of the closure. + (wrap (|> bodyO + _.return + (_.lambda #.None (list (..register register))) + (_.apply_lambda/* (list valueO)))))) + +(def: #export (let! statement expression archive [valueS register bodyS]) + (Generator! [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (statement expression archive bodyS)] + (wrap ($_ _.then + (_.set (list (..register register)) valueO) + bodyO)))) + +(def: #export (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (wrap (_.? testO thenO elseO)))) + +(def: #export (if! statement expression archive [testS thenS elseS]) + (Generator! [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [test! (expression archive testS) + then! (statement expression archive thenS) + else! (statement expression archive elseS)] + (wrap (_.if test! + then! + else!)))) + +(def: #export (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (wrap (list\fold (function (_ side source) + (.let [method (.case side + (^template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.int (.int lefts)))]) + ([#.Left //runtime.tuple//left] + [#.Right //runtime.tuple//right]))] + (method source))) + valueO + (list.reverse pathP))))) + +(def: @savepoint (_.local "lux_pm_savepoint")) +(def: @cursor (_.local "lux_pm_cursor")) +(def: @temp (_.local "lux_pm_temp")) + +(def: (push! value) + (-> Expression Statement) + (_.statement (|> @cursor (_.do "push" (list value))))) + +(def: peek_and_pop + Expression + (|> @cursor (_.do "pop" (list)))) + +(def: pop! + Statement + (_.statement ..peek_and_pop)) + +(def: peek + Expression + (_.nth (_.int -1) @cursor)) + +(def: save! + Statement + (.let [cursor (_.array_range (_.int +0) (_.int -1) @cursor)] + (_.statement (|> @savepoint (_.do "push" (list cursor)))))) + +(def: restore! + Statement + (_.set (list @cursor) (|> @savepoint (_.do "pop" (list))))) + +(def: fail! _.break) + +(def: (multi_pop! pops) + (-> Nat Statement) + (_.statement (_.do "slice!" (list (_.int (i.* -1 (.int pops))) + (_.int (.int pops))) + @cursor))) + +(template [<name> <flag> <prep>] + [(def: (<name> simple? idx) + (-> Bit Nat Statement) + ($_ _.then + (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) + (.if simple? + (_.when (_.= _.nil @temp) + fail!) + (_.if (_.= _.nil @temp) + fail! + (..push! @temp)))))] + + [left_choice _.nil (<|)] + [right_choice (_.string "") inc] + ) + +(def: (with_looping in_closure? g!once g!continue? body!) + (-> Bit LVar LVar Statement Statement) + (.if in_closure? + ($_ _.then + (_.while (_.bool true) + body!)) + ($_ _.then + (_.set (list g!once) (_.bool true)) + (_.set (list g!continue?) (_.bool false)) + (<| (_.while (_.bool true)) + (_.if g!once + ($_ _.then + (_.set (list g!once) (_.bool false)) + body!) + ($_ _.then + (_.set (list g!continue?) (_.bool true)) + _.break))) + (_.when g!continue? + _.next)))) + +(def: (alternation in_closure? g!once g!continue? pre! post!) + (-> Bit LVar LVar Statement Statement Statement) + ($_ _.then + (with_looping in_closure? g!once g!continue? + ($_ _.then + ..save! + pre!)) + ..restore! + post!)) + +(def: (primitive_pattern_matching recur pathP) + (-> (-> Path (Operation Statement)) + (-> Path (Operation (Maybe Statement)))) + (.case pathP + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail!))] + (wrap (#.Some (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!))))) + + (^template [<tag> <format>] + [(<tag> cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (\ ! map + (|>> [(_.= (|> match <format>) + ..peek)]) + (recur then))) + (#.Cons cons))] + (wrap (#.Some (_.cond clauses + ..fail!))))]) + ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)] + [#/////synthesis.F64_Fork (<| //primitive.f64)] + [#/////synthesis.Text_Fork (<| //primitive.text)]) + + _ + (\ ///////phase.monad wrap #.None))) + +(def: (pattern_matching' in_closure? statement expression archive) + (-> Bit (Generator! Path)) + (function (recur pathP) + (do ///////phase.monad + [?output (primitive_pattern_matching recur pathP)] + (.case ?output + (#.Some output) + (wrap output) + + #.None + (.case pathP + (#/////synthesis.Then bodyS) + (statement expression archive bodyS) + + #/////synthesis.Pop + (///////phase\wrap ..pop!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.set (list (..register register)) ..peek)) + + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail!))] + (wrap (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^template [<tag> <format>] + [(<tag> cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (\ ! map + (|>> [(_.= (|> match <format>) + ..peek)]) + (recur then))) + (#.Cons cons))] + (wrap (_.cond clauses + ..fail!)))]) + ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)] + [#/////synthesis.F64_Fork (<| //primitive.f64)] + [#/////synthesis.Text_Fork (<| //primitive.text)]) + + (^template [<complex> <simple> <choice>] + [(^ (<complex> idx)) + (///////phase\wrap (<choice> false idx)) + + (^ (<simple> idx nextP)) + (|> nextP + recur + (///////phase\map (_.then (<choice> true idx))))]) + ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] + [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!)) + + (^template [<pm> <getter>] + [(^ (<pm> lefts)) + (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^ (/////synthesis.!bind_top register thenP)) + (do ///////phase.monad + [then! (recur thenP)] + (///////phase\wrap ($_ _.then + (_.set (list (..register register)) ..peek_and_pop) + then!))) + + (^ (/////synthesis.!multi_pop nextP)) + (.let [[extra_pops nextP'] (case.count_pops nextP)] + (do ///////phase.monad + [next! (recur nextP')] + (///////phase\wrap ($_ _.then + (..multi_pop! (n.+ 2 extra_pops)) + next!)))) + + (^ (/////synthesis.path/seq preP postP)) + (do ///////phase.monad + [pre! (recur preP) + post! (recur postP)] + (wrap ($_ _.then + pre! + post!))) + + (^ (/////synthesis.path/alt preP postP)) + (do ///////phase.monad + [pre! (recur preP) + post! (recur postP) + g!once (..gensym "once") + g!continue? (..gensym "continue")] + (wrap (..alternation in_closure? g!once g!continue? pre! post!))) + + _ + (undefined)))))) + +(def: (pattern_matching in_closure? statement expression archive pathP) + (-> Bit (Generator! Path)) + (do ///////phase.monad + [pattern_matching! (pattern_matching' in_closure? statement expression archive pathP) + g!once (..gensym "once") + g!continue? (..gensym "continue")] + (wrap ($_ _.then + (..with_looping in_closure? g!once g!continue? + pattern_matching!) + (_.statement (_.raise (_.string case.pattern_matching_error))))))) + +(def: #export (case! in_closure? statement expression archive [valueS pathP]) + (-> Bit (Generator! [Synthesis Path])) + (do ///////phase.monad + [stack_init (expression archive valueS) + pattern_matching! (pattern_matching in_closure? statement expression archive pathP)] + (wrap ($_ _.then + (_.set (list @cursor) (_.array (list stack_init))) + (_.set (list @savepoint) (_.array (list))) + pattern_matching! + )))) + +(def: #export (case statement expression archive case) + (-> Phase! (Generator [Synthesis Path])) + (|> case + (case! true statement expression archive) + (\ ///////phase.monad map + (|>> (_.lambda #.None (list)) + (_.apply_lambda/* (list)))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux new file mode 100644 index 000000000..af7906c9c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux @@ -0,0 +1,112 @@ +(.module: + [library + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [target + ["_" ruby (#+ LVar GVar Expression Statement)]]]] + ["." // #_ + [runtime (#+ Operation Phase Generator Phase! Generator!)] + ["#." reference] + ["#." case] + ["#." loop] + ["/#" // #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["#." generation (#+ Context)] + ["//#" /// #_ + [arity (#+ Arity)] + ["#." phase] + [reference + [variable (#+ Register Variable)]] + [meta + [archive (#+ Archive) + ["." artifact]]]]]]]) + +(def: #export (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do {! ///////phase.monad} + [functionO (expression archive functionS) + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply_lambda/* argsO+ functionO)))) + +(def: #export capture + (-> Register LVar) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: (with_closure inits self function_definition) + (-> (List Expression) Text Expression [Statement Expression]) + (case inits + #.Nil + (let [@self (_.global self)] + [(_.set (list @self) function_definition) + @self]) + + _ + (let [@self (_.local self)] + [(_.function @self + (|> (list.enumeration inits) + (list\map (|>> product.left ..capture))) + ($_ _.then + (_.set (list @self) function_definition) + (_.return @self))) + (_.apply/* inits @self)]))) + +(def: input + (|>> inc //case.register)) + +(def: #export (function statement expression archive [environment arity bodyS]) + (-> Phase! (Generator (Abstraction Synthesis))) + (do {! ///////phase.monad} + [[[function_module function_artifact] body!] (/////generation.with_new_context archive + (/////generation.with_anchor 1 + (statement expression archive bodyS))) + closureO+ (monad.map ! (expression archive) environment) + #let [function_name (///reference.artifact [function_module function_artifact]) + @curried (_.local "curried") + arityO (|> arity .int _.int) + limitO (|> arity dec .int _.int) + @num_args (_.local "num_args") + @self (_.local function_name) + initialize_self! (_.set (list (//case.register 0)) @self) + initialize! (list\fold (.function (_ post pre!) + ($_ _.then + pre! + (_.set (list (..input post)) (_.nth (|> post .int _.int) @curried)))) + initialize_self! + (list.indices arity)) + [declaration instatiation] (with_closure closureO+ function_name + (_.lambda (#.Some @self) (list (_.variadic @curried)) + ($_ _.then + (_.set (list @num_args) (_.the "length" @curried)) + (_.cond (list [(|> @num_args (_.= arityO)) + (<| (_.then initialize!) + //loop.with_scope + body!)] + [(|> @num_args (_.> arityO)) + (let [slice (.function (_ from to) + (_.array_range from to @curried)) + arity_args (_.splat (slice (_.int +0) limitO)) + output_func_args (_.splat (slice arityO @num_args))] + (_.return (|> @self + (_.apply_lambda/* (list arity_args)) + (_.apply_lambda/* (list output_func_args)))))]) + ## (|> @num_args (_.< arityO)) + (let [@missing (_.local "missing")] + (_.return (_.lambda #.None (list (_.variadic @missing)) + (_.return (|> @self + (_.apply_lambda/* (list (_.splat (|> (_.array (list)) + (_.do "concat" (list @curried)) + (_.do "concat" (list @missing)))))))))))) + )))] + _ (/////generation.execute! declaration) + _ (/////generation.save! function_artifact declaration)] + (wrap instatiation))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux new file mode 100644 index 000000000..c1639df6a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux @@ -0,0 +1,96 @@ +(.module: + [library + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set]]] + [math + [number + ["n" nat]]] + [target + ["_" ruby (#+ Expression LVar Statement)]]]] + ["." // #_ + [runtime (#+ Operation Phase Generator Phase! Generator!)] + ["#." case] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + [synthesis + ["." case]] + ["/#" // #_ + ["." synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [reference + ["#." variable (#+ Register)]]]]]]]) + +(def: (setup offset bindings body) + (-> Register (List Expression) Statement Statement) + (|> bindings + list.enumeration + (list\map (function (_ [register value]) + (_.set (list (//case.register (n.+ offset register))) + value))) + list.reverse + (list\fold _.then body))) + +(def: symbol + (_.symbol "lux_continue")) + +(def: #export with_scope + (-> Statement Statement) + (_.while (_.bool true))) + +(def: #export (scope! statement expression archive [start initsS+ bodyS]) + (Generator! (Scope Synthesis)) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (statement expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [initsO+ (monad.map ! (expression archive) initsS+) + body! (/////generation.with_anchor start + (statement expression archive bodyS))] + (wrap (<| (..setup start initsO+) + ..with_scope + body!))))) + +(def: #export (scope statement expression archive [start initsS+ bodyS]) + (-> Phase! (Generator (Scope Synthesis))) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [body! (scope! statement expression archive [start initsS+ bodyS])] + (wrap (|> body! + (_.lambda #.None (list)) + (_.apply_lambda/* (list))))))) + +(def: #export (recur! statement expression archive argsS+) + (Generator! (List Synthesis)) + (do {! ///////phase.monad} + [offset /////generation.anchor + @temp (//case.gensym "lux_recur_values") + argsO+ (monad.map ! (expression archive) argsS+) + #let [re_binds (|> argsO+ + list.enumeration + (list\map (function (_ [idx _]) + (_.nth (_.int (.int idx)) @temp))))]] + (wrap ($_ _.then + (_.set (list @temp) (_.array argsO+)) + (..setup offset re_binds + _.next))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux new file mode 100644 index 000000000..0f01d2455 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux @@ -0,0 +1,16 @@ +(.module: + [library + [lux (#- i64) + [target + ["_" ruby (#+ Literal)]]]]) + +(template [<type> <name> <implementation>] + [(def: #export <name> + (-> <type> Literal) + <implementation>)] + + [Bit bit _.bool] + [(I64 Any) i64 (|>> .int _.int)] + [Frac f64 _.float] + [Text text _.string] + ) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux new file mode 100644 index 000000000..a54e6da57 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" ruby (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System Expression) + + (def: constant _.global) + (def: variable _.local)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux new file mode 100644 index 000000000..2ce60a9a1 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux @@ -0,0 +1,403 @@ +(.module: + [library + [lux (#- inc) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<.>" code]]] + [data + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." list ("#\." functor)] + ["." row]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["." i64]]] + ["@" target + ["_" ruby (#+ Expression LVar Computation Literal Statement)]]]] + ["." /// #_ + ["#." reference] + ["//#" /// #_ + ["$" version] + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// + ["#." phase] + [reference + [variable (#+ Register)]] + [meta + [archive (#+ Output Archive) + ["." artifact (#+ Registry)]]]]]]) + +(template [<name> <base>] + [(type: #export <name> + (<base> Register Expression Statement))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type: #export (Generator i) + (-> Phase Archive i (Operation Expression))) + +(type: #export Phase! + (-> Phase Archive Synthesis (Operation Statement))) + +(type: #export (Generator! i) + (-> Phase! Phase Archive i (Operation Statement))) + +(def: #export unit + (_.string /////synthesis.unit)) + +(def: (flag value) + (-> Bit Literal) + (if value + ..unit + _.nil)) + +(def: (feature name definition) + (-> LVar (-> LVar Statement) Statement) + (definition name)) + +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} + body) + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.local (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(def: module_id + 0) + +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} + code) + (do meta.monad + [runtime_id meta.count] + (macro.with_gensyms [g!_] + (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.local (~ (code.text (%.code runtime)))))] + (case declaration + (#.Left name) + (macro.with_gensyms [g!_] + (let [g!name (code.local_identifier name)] + (wrap (list (` (def: #export (~ g!name) LVar (~ runtime_name))) + (` (def: (~ (code.local_identifier (format "@" name))) + Statement + (..feature (~ runtime_name) + (function ((~ g!_) (~ g!name)) + (_.set (list (~ g!name)) (~ code)))))))))) + + (#.Right [name inputs]) + (macro.with_gensyms [g!_] + (let [g!name (code.local_identifier name) + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` _.Expression)) + inputs)] + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) + (-> (~+ inputs_typesC) Computation) + (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) + + (` (def: (~ (code.local_identifier (format "@" name))) + Statement + (..feature (~ runtime_name) + (function ((~ g!_) (~ g!_)) + (..with_vars [(~+ inputsC)] + (_.function (~ g!_) (list (~+ inputsC)) + (~ code)))))))))))))))) + +(def: tuple_size + (_.the "length")) + +(def: last_index + (|>> ..tuple_size (_.- (_.int +1)))) + +(with_expansions [<recur> (as_is ($_ _.then + (_.set (list lefts) (_.- last_index_right lefts)) + (_.set (list tuple) (_.nth last_index_right tuple))))] + (runtime: (tuple//left lefts tuple) + (with_vars [last_index_right] + (<| (_.while (_.bool true)) + ($_ _.then + (_.set (list last_index_right) (..last_index tuple)) + (_.if (_.> lefts last_index_right) + ## No need for recursion + (_.return (_.nth lefts tuple)) + ## Needs recursion + <recur>))))) + + (runtime: (tuple//right lefts tuple) + (with_vars [last_index_right right_index] + (<| (_.while (_.bool true)) + ($_ _.then + (_.set (list last_index_right) (..last_index tuple)) + (_.set (list right_index) (_.+ (_.int +1) lefts)) + (_.cond (list [(_.= last_index_right right_index) + (_.return (_.nth right_index tuple))] + [(_.> last_index_right right_index) + ## Needs recursion. + <recur>]) + (_.return (_.array_range right_index (..tuple_size tuple) tuple))) + ))))) + +(def: #export variant_tag_field "_lux_tag") +(def: #export variant_flag_field "_lux_flag") +(def: #export variant_value_field "_lux_value") + +(runtime: (sum//make tag last? value) + (_.return (_.hash (list [(_.string ..variant_tag_field) tag] + [(_.string ..variant_flag_field) last?] + [(_.string ..variant_value_field) value])))) + +(def: #export (variant tag last? value) + (-> Nat Bit Expression Computation) + (sum//make (_.int (.int tag)) (..flag last?) value)) + +(def: #export none + Computation + (..variant 0 #0 ..unit)) + +(def: #export some + (-> Expression Computation) + (..variant 1 #1)) + +(def: #export left + (-> Expression Computation) + (..variant 0 #0)) + +(def: #export right + (-> Expression Computation) + (..variant 1 #1)) + +(runtime: (sum//get sum wantsLast wantedTag) + (let [no_match! (_.return _.nil) + sum_tag (_.nth (_.string ..variant_tag_field) sum) + sum_flag (_.nth (_.string ..variant_flag_field) sum) + sum_value (_.nth (_.string ..variant_value_field) sum) + is_last? (_.= ..unit sum_flag) + test_recursion! (_.if is_last? + ## Must recurse. + ($_ _.then + (_.set (list wantedTag) (_.- sum_tag wantedTag)) + (_.set (list sum) sum_value)) + no_match!)] + (<| (_.while (_.bool true)) + (_.cond (list [(_.= sum_tag wantedTag) + (_.if (_.= wantsLast sum_flag) + (_.return sum_value) + test_recursion!)] + + [(_.< wantedTag sum_tag) + test_recursion!] + + [(_.= ..unit wantsLast) + (_.return (sum//make (_.- wantedTag sum_tag) sum_flag sum_value))]) + + no_match!)))) + +(def: runtime//adt + Statement + ($_ _.then + @tuple//left + @tuple//right + @sum//make + @sum//get + )) + +(runtime: (lux//try risky) + (with_vars [error value] + (_.begin ($_ _.then + (_.set (list value) (_.apply_lambda/* (list ..unit) risky)) + (_.return (..right value))) + (list [(list) error + (_.return (..left (_.the "message" error)))])))) + +(runtime: (lux//program_args raw) + (with_vars [tail head] + ($_ _.then + (_.set (list tail) ..none) + (<| (_.for_in head raw) + (_.set (list tail) (..some (_.array (list head tail))))) + (_.return tail)))) + +(def: runtime//lux + Statement + ($_ _.then + @lux//try + @lux//program_args + )) + +(def: i64//+limit (_.manual "+0x7FFFFFFFFFFFFFFF")) +(def: i64//-limit (_.manual "-0x8000000000000000")) +(def: i64//+iteration (_.manual "+0x10000000000000000")) +(def: i64//-iteration (_.manual "-0x10000000000000000")) +(def: i64//+cap (_.manual "+0x8000000000000000")) +(def: i64//-cap (_.manual "-0x8000000000000001")) + +(runtime: (i64//64 input) + (with_vars [temp] + (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>] + [(_.if (|> input <scenario>) + ($_ _.then + (_.set (list temp) (_.% <iteration> input)) + (_.return (_.? (|> temp <scenario>) + (|> temp (_.- <cap>) (_.+ <entrance>)) + temp))))] + + [(_.> ..i64//+limit) ..i64//+iteration ..i64//+cap ..i64//-limit] + [(_.< ..i64//-limit) ..i64//-iteration ..i64//-cap ..i64//+limit] + )) + (_.return input))))) + +(runtime: i64//nat_top + (|> (_.int +1) + (_.bit_shl (_.int +64)) + (_.- (_.int +1)))) + +(def: as_nat + (_.% (_.manual "0x10000000000000000"))) + +(runtime: (i64//left_shift param subject) + (_.return (|> subject + (_.bit_shl (_.% (_.int +64) param)) + ..i64//64))) + +(runtime: (i64//right_shift param subject) + ($_ _.then + (_.set (list param) (_.% (_.int +64) param)) + (_.return (_.? (_.= (_.int +0) param) + subject + (|> subject + ..as_nat + (_.bit_shr param)))))) + +(template [<runtime> <host>] + [(runtime: (<runtime> left right) + (_.return (..i64//64 (<host> (..as_nat left) (..as_nat right)))))] + + [i64//and _.bit_and] + [i64//or _.bit_or] + [i64//xor _.bit_xor] + ) + +(runtime: (i64//division parameter subject) + (let [extra (_.do "remainder" (list parameter) subject)] + (_.return (|> subject + (_.- extra) + (_./ parameter))))) + +(def: runtime//i64 + Statement + ($_ _.then + @i64//64 + @i64//nat_top + @i64//left_shift + @i64//right_shift + @i64//and + @i64//or + @i64//xor + @i64//division + )) + +(runtime: (f64//decode inputG) + (with_vars [@input @temp] + ($_ _.then + (_.set (list @input) inputG) + (_.set (list @temp) (_.do "to_f" (list) @input)) + (_.if ($_ _.or + (_.not (_.= (_.float +0.0) @temp)) + (_.= (_.string "0") @input) + (_.= (_.string ".0") @input) + (_.= (_.string "0.0") @input)) + (_.return (..some @temp)) + (_.return ..none))))) + +(def: runtime//f64 + Statement + ($_ _.then + @f64//decode + )) + +(runtime: (text//index subject param start) + (with_vars [idx] + ($_ _.then + (_.set (list idx) (|> subject (_.do "index" (list param start)))) + (_.if (_.= _.nil idx) + (_.return ..none) + (_.return (..some idx)))))) + +(def: (within? top value) + (-> Expression Expression Computation) + (_.and (|> value (_.>= (_.int +0))) + (|> value (_.< top)))) + +(runtime: (text//clip offset length text) + (_.if (_.= (_.int +0) length) + (_.return (_.string "")) + (_.return (_.array_range offset (_.+ offset (_.- (_.int +1) length)) text)))) + +(runtime: (text//char idx text) + (_.if (|> idx (within? (_.the "length" text))) + (_.return (|> text (_.array_range idx idx) (_.do "ord" (list)))) + (_.statement (_.raise (_.string "[Lux Error] Cannot get char from text."))))) + +(def: runtime//text + Statement + ($_ _.then + @text//index + @text//clip + @text//char + )) + +(runtime: (array//write idx value array) + ($_ _.then + (_.set (list (_.nth idx array)) value) + (_.return array))) + +(def: runtime//array + Statement + ($_ _.then + @array//write + )) + +(def: runtime + Statement + ($_ _.then + runtime//adt + runtime//lux + runtime//i64 + runtime//f64 + runtime//text + runtime//array + )) + +(def: #export generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! ..module_id ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row [..module_id + (|> ..runtime + _.code + (\ utf8.codec encode))])]))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux new file mode 100644 index 000000000..c172b43b8 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux @@ -0,0 +1,37 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [target + ["_" ruby (#+ Expression)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." primitive] + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + ["//#" /// #_ + ["#." phase ("#\." monad)]]]]) + +(def: #export (tuple generate archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + #.Nil + (///////phase\wrap (//primitive.text /////synthesis.unit)) + + (#.Cons singletonS #.Nil) + (generate archive singletonS) + + _ + (|> elemsS+ + (monad.map ///////phase.monad (generate archive)) + (///////phase\map _.array)))) + +(def: #export (variant generate archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (inc lefts) + lefts)] + (///////phase\map (//runtime.variant tag right?) + (generate archive valueS)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme.lux new file mode 100644 index 000000000..98f7b88bb --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme.lux @@ -0,0 +1,59 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [target + ["_" scheme]]]] + ["." / #_ + [runtime (#+ Phase)] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." loop] + ["#." function] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + [analysis (#+)] + ["#." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) + +(def: #export (generate archive synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + [(^ (<tag> value)) + (//////phase\wrap (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + (#////synthesis.Reference value) + (//reference.reference /reference.system archive value) + + (^template [<tag> <generator>] + [(^ (<tag> value)) + (<generator> generate archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + [////synthesis.function/apply /function.apply] + + [////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.loop/recur /loop.recur] + [////synthesis.function/abstraction /function.function]) + + (#////synthesis.Extension extension) + (///extension.apply archive generate extension) + )) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux new file mode 100644 index 000000000..99d115b9d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux @@ -0,0 +1,223 @@ +(.module: + [library + [lux (#- case let if) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set]]] + [macro + ["." template]] + [math + [number + ["i" int]]] + [target + ["_" scheme (#+ Expression Computation Var)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] + ["#." primitive] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." synthesis #_ + ["#/." case]] + ["/#" // #_ + ["#." synthesis (#+ Member Synthesis Path)] + ["#." generation] + ["//#" /// #_ + [reference + ["#." variable (#+ Register)]] + ["#." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]]) + +(def: #export register + (-> Register Var) + (|>> (///reference.local //reference.system) :assume)) + +(def: #export capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: #export (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + (wrap (_.let (list [(..register register) valueO]) + bodyO)))) + +(def: #export (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (wrap (_.if testO thenO elseO)))) + +(def: #export (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (wrap (list\fold (function (_ side source) + (.let [method (.case side + (^template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.int (.int lefts)))]) + ([#.Left //runtime.tuple//left] + [#.Right //runtime.tuple//right]))] + (method source))) + valueO + (list.reverse pathP))))) + +(def: @savepoint (_.var "lux_pm_cursor_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) +(def: @alt_error (_.var "alt_error")) + +(def: (push! value var) + (-> Expression Var Computation) + (_.set! var (_.cons/2 value var))) + +(def: (push_cursor! value) + (-> Expression Computation) + (push! value @cursor)) + +(def: (pop! var) + (-> Var Computation) + (_.set! var (_.cdr/1 var))) + +(def: save_cursor! + Computation + (push! @cursor @savepoint)) + +(def: restore_cursor! + Computation + (_.begin (list (_.set! @cursor (_.car/1 @savepoint)) + (_.set! @savepoint (_.cdr/1 @savepoint))))) + +(def: peek + Computation + (_.car/1 @cursor)) + +(def: pop_cursor! + Computation + (pop! @cursor)) + +(def: pm_error + (_.string (template.with_locals [pm_error] + (template.text [pm_error])))) + +(def: fail! + (_.raise/1 pm_error)) + +(def: (try_pm on_failure happy_path) + (-> Expression Expression Computation) + (_.guard @alt_error + (list [(_.and (list (_.string?/1 @alt_error) + (_.string=?/2 ..pm_error @alt_error))) + on_failure]) + #.None + happy_path)) + +(def: (pattern_matching' expression archive) + (Generator Path) + (function (recur pathP) + (.case pathP + (#/////synthesis.Then bodyS) + (expression archive bodyS) + + #/////synthesis.Pop + (///////phase\wrap pop_cursor!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.define_constant (..register register) ..peek)) + + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail!))] + (wrap (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^template [<tag> <format> <=>] + [(<tag> cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (do ! + [then! (recur then)] + (wrap [(<=> (|> match <format>) + ..peek) + then!]))) + (#.Cons cons))] + (wrap (list\fold (function (_ [when then] else) + (_.if when then else)) + ..fail! + clauses)))]) + ([#/////synthesis.I64_Fork //primitive.i64 _.=/2] + [#/////synthesis.F64_Fork //primitive.f64 _.=/2] + [#/////synthesis.Text_Fork //primitive.text _.string=?/2]) + + (^template [<pm> <flag> <prep>] + [(^ (<pm> idx)) + (///////phase\wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek (_.bool <flag>)))]) + (_.if (_.null?/1 @temp) + ..fail! + (push_cursor! @temp))))]) + ([/////synthesis.side/left false (<|)] + [/////synthesis.side/right true inc]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (..push_cursor! (_.vector-ref/2 ..peek (_.int +0)))) + + (^template [<pm> <getter>] + [(^ (<pm> lefts)) + (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push_cursor!))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^ (/////synthesis.path/seq leftP rightP)) + (do ///////phase.monad + [leftO (recur leftP) + rightO (recur rightP)] + (wrap (_.begin (list leftO + rightO)))) + + (^ (/////synthesis.path/alt leftP rightP)) + (do {! ///////phase.monad} + [leftO (recur leftP) + rightO (recur rightP)] + (wrap (try_pm (_.begin (list restore_cursor! + rightO)) + (_.begin (list save_cursor! + leftO))))) + ))) + +(def: (pattern_matching expression archive pathP) + (Generator Path) + (\ ///////phase.monad map + (try_pm (_.raise/1 (_.string "Invalid expression for pattern-matching."))) + (pattern_matching' expression archive pathP))) + +(def: #export (case expression archive [valueS pathP]) + (Generator [Synthesis Path]) + (do {! ///////phase.monad} + [valueO (expression archive valueS)] + (<| (\ ! map (_.let (list [@cursor (_.list/* (list valueO))] + [@savepoint (_.list/* (list))]))) + (pattern_matching expression archive pathP)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux new file mode 100644 index 000000000..1880d7700 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux @@ -0,0 +1,14 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common]]) + +(def: #export bundle + Bundle + common.bundle) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux new file mode 100644 index 000000000..0275e8cd9 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux @@ -0,0 +1,223 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["ex" exception (#+ exception:)] + [parser + ["s" code]]] + [data + ["." product] + ["." text] + [number (#+ hex) + ["f" frac]] + [collection + ["." list ("#\." functor)] + ["dict" dictionary (#+ Dictionary)]]] + ["." macro (#+ with-gensyms) + ["." code] + [syntax (#+ syntax:)]] + [target + ["_" scheme (#+ Expression Computation)]]]] + ["." /// #_ + ["#." runtime (#+ Operation Phase Handler Bundle)] + ["#//" /// + ["#." extension + ["." bundle]] + ["#/" // #_ + ["#." synthesis (#+ Synthesis)]]]]) + +(syntax: (Vector {size s.nat} elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector 0 Expression) Computation)) +(type: #export Unary (-> (Vector 1 Expression) Computation)) +(type: #export Binary (-> (Vector 2 Expression) Computation)) +(type: #export Trinary (-> (Vector 3 Expression) Computation)) +(type: #export Variadic (-> (List Expression) Computation)) + +(syntax: (arity: {name s.local-identifier} {arity s.nat}) + (with-gensyms [g!_ g!extension g!name g!phase g!inputs] + (do {! macro.monad} + [g!input+ (monad.seq ! (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) + Handler) + (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do /////.monad + [(~+ (|> g!input+ + (list\map (function (_ g!input) + (list g!input (` ((~ g!phase) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) + + (~' _) + (/////.throw /////extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) + +(arity: nullary 0) +(arity: unary 1) +(arity: binary 2) +(arity: trinary 3) + +(def: #export (variadic extension) + (-> Variadic Handler) + (function (_ extension-name) + (function (_ phase inputsS) + (do {! /////.monad} + [inputsI (monad.map ! phase inputsS)] + (wrap (extension inputsI)))))) + +(def: bundle::lux + Bundle + (|> bundle.empty + (bundle.install "is?" (binary (product.uncurry _.eq?/2))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [i64::and _.bit-and/2] + [i64::or _.bit-or/2] + [i64::xor _.bit-xor/2] + ) + +(def: (i64::left-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO) + subjectO)) + +(def: (i64::arithmetic-right-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1))) + subjectO)) + +(def: (i64::logical-right-shift [subjectO paramO]) + Binary + (///runtime.i64//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO)) + +(template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (|> subjectO (<op> paramO)))] + + [i64::+ _.+/2] + [i64::- _.-/2] + [i64::* _.*/2] + [i64::/ _.quotient/2] + [i64::% _.remainder/2] + ) + +(template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [f64::+ _.+/2] + [f64::- _.-/2] + [f64::* _.*/2] + [f64::/ _.//2] + [f64::% _.mod/2] + [f64::= _.=/2] + [f64::< _.</2] + + [text::= _.string=?/2] + [text::< _.string<?/2] + ) + +(template [<name> <cmp>] + [(def: (<name> [subjectO paramO]) + Binary + (<cmp> paramO subjectO))] + + [i64::= _.=/2] + [i64::< _.</2] + ) + +(def: i64::char (|>> _.integer->char/1 _.string/1)) + +(def: bundle::i64 + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary i64::and)) + (bundle.install "or" (binary i64::or)) + (bundle.install "xor" (binary i64::xor)) + (bundle.install "left-shift" (binary i64::left-shift)) + (bundle.install "logical-right-shift" (binary i64::logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift)) + (bundle.install "+" (binary i64::+)) + (bundle.install "-" (binary i64::-)) + (bundle.install "*" (binary i64::*)) + (bundle.install "/" (binary i64::/)) + (bundle.install "%" (binary i64::%)) + (bundle.install "=" (binary i64::=)) + (bundle.install "<" (binary i64::<)) + (bundle.install "f64" (unary (|>> (_.//2 (_.float +1.0))))) + (bundle.install "char" (unary i64::char))))) + +(def: bundle::f64 + Bundle + (<| (bundle.prefix "f64") + (|> bundle.empty + (bundle.install "+" (binary f64::+)) + (bundle.install "-" (binary f64::-)) + (bundle.install "*" (binary f64::*)) + (bundle.install "/" (binary f64::/)) + (bundle.install "%" (binary f64::%)) + (bundle.install "=" (binary f64::=)) + (bundle.install "<" (binary f64::<)) + (bundle.install "i64" (unary _.exact/1)) + (bundle.install "encode" (unary _.number->string/1)) + (bundle.install "decode" (unary ///runtime.frac//decode))))) + +(def: (text::char [subjectO paramO]) + Binary + (_.string/1 (_.string-ref/2 subjectO paramO))) + +(def: (text::clip [subjectO startO endO]) + Trinary + (_.substring/3 subjectO startO endO)) + +(def: bundle::text + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary text::=)) + (bundle.install "<" (binary text::<)) + (bundle.install "concat" (binary (product.uncurry _.string-append/2))) + (bundle.install "size" (unary _.string-length/1)) + (bundle.install "char" (binary text::char)) + (bundle.install "clip" (trinary text::clip))))) + +(def: (io::log input) + Unary + (_.begin (list (_.display/1 input) + _.newline/0))) + +(def: (void code) + (-> Expression Computation) + (_.begin (list code (_.string //////synthesis.unit)))) + +(def: bundle::io + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary (|>> io::log ..void))) + (bundle.install "error" (unary _.raise/1)) + (bundle.install "exit" (unary _.exit/1)) + (bundle.install "current-time" (nullary (function (_ _) (///runtime.io//current-time (_.string //////synthesis.unit)))))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> bundle::lux + (dict.merge bundle::i64) + (dict.merge bundle::f64) + (dict.merge bundle::text) + (dict.merge bundle::io) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux new file mode 100644 index 000000000..b12ddcde3 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux @@ -0,0 +1,101 @@ +(.module: + [library + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + pipe] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [target + ["_" scheme (#+ Expression Computation Var)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] + ["#." case] + ["/#" // #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant Tuple Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["#." generation (#+ Context)] + ["//#" /// #_ + [arity (#+ Arity)] + ["#." phase ("#\." monad)] + [reference + [variable (#+ Register Variable)]]]]]]) + +(def: #export (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do {! ///////phase.monad} + [functionO (expression archive functionS) + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply/* argsO+ functionO)))) + +(def: capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: (with_closure inits function_definition) + (-> (List Expression) Computation (Operation Computation)) + (///////phase\wrap + (case inits + #.Nil + function_definition + + _ + (|> function_definition + (_.lambda [(|> (list.enumeration inits) + (list\map (|>> product.left ..capture))) + #.None]) + (_.apply/* inits))))) + +(def: @curried (_.var "curried")) +(def: @missing (_.var "missing")) + +(def: input + (|>> inc //case.register)) + +(def: #export (function expression archive [environment arity bodyS]) + (Generator (Abstraction Synthesis)) + (do {! ///////phase.monad} + [[function_name bodyO] (/////generation.with_new_context archive + (do ! + [@self (\ ! map (|>> ///reference.artifact _.var) + (/////generation.context archive))] + (/////generation.with_anchor @self + (expression archive bodyS)))) + closureO+ (monad.map ! (expression archive) environment) + #let [arityO (|> arity .int _.int) + apply_poly (.function (_ args func) + (_.apply/2 (_.var "apply") func args)) + @num_args (_.var "num_args") + @self (_.var (///reference.artifact function_name))]] + (with_closure closureO+ + (_.letrec (list [@self (_.lambda [(list) (#.Some @curried)] + (_.let (list [@num_args (_.length/1 @curried)]) + (<| (_.if (|> @num_args (_.=/2 arityO)) + (<| (_.let (list [(//case.register 0) @self])) + (_.let_values (list [[(|> (list.indices arity) + (list\map ..input)) + #.None] + (_.apply/2 (_.var "apply") (_.var "values") @curried)])) + bodyO)) + (_.if (|> @num_args (_.>/2 arityO)) + (let [arity_args (//runtime.slice (_.int +0) arityO @curried) + output_func_args (//runtime.slice arityO + (|> @num_args (_.-/2 arityO)) + @curried)] + (_.begin (list (|> @self + (apply_poly arity_args) + (apply_poly output_func_args)))))) + ## (|> @num_args (_.</2 arityO)) + (_.lambda [(list) (#.Some @missing)] + (|> @self + (apply_poly (_.append/2 @curried @missing))))) + ))]) + @self)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux new file mode 100644 index 000000000..23718bfc5 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux @@ -0,0 +1,64 @@ +(.module: + [library + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set (#+ Set)]]] + [math + [number + ["n" nat]]] + [target + ["_" scheme]]]] + ["." // #_ + [runtime (#+ Operation Phase Generator)] + ["#." case] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + [synthesis + ["." case]] + ["/#" // #_ + ["."synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [meta + [archive (#+ Archive)]] + [reference + [variable (#+ Register)]]]]]]]) + +(def: @scope + (_.var "scope")) + +(def: #export (scope expression archive [start initsS+ bodyS]) + (Generator (Scope Synthesis)) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [initsO+ (monad.map ! (expression archive) initsS+) + bodyO (/////generation.with_anchor @scope + (expression archive bodyS))] + (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+ + list.enumeration + (list\map (|>> product.left (n.+ start) //case.register))) + #.None] + bodyO)]) + (_.apply/* initsO+ @scope)))))) + +(def: #export (recur expression archive argsS+) + (Generator (List Synthesis)) + (do {! ///////phase.monad} + [@scope /////generation.anchor + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply/* argsO+ @scope)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux new file mode 100644 index 000000000..a7c2b81b6 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux @@ -0,0 +1,16 @@ +(.module: + [library + [lux (#- i64) + [target + ["_" scheme (#+ Expression)]]]]) + +(template [<name> <type> <code>] + [(def: #export <name> + (-> <type> Expression) + <code>)] + + [bit Bit _.bool] + [i64 (I64 Any) (|>> .int _.int)] + [f64 Frac _.float] + [text Text _.string] + ) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux new file mode 100644 index 000000000..19d46ba19 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" scheme (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System Expression) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux new file mode 100644 index 000000000..ec3def7fd --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux @@ -0,0 +1,370 @@ +(.module: + [library + [lux (#- Location inc) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<.>" code]]] + [data + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." list ("#\." functor)] + ["." row]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["." i64]]] + ["@" target + ["_" scheme (#+ Expression Computation Var)]]]] + ["." /// #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant)] + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// + ["#." phase] + [reference + [variable (#+ Register)]] + [meta + [archive (#+ Output Archive) + ["." artifact (#+ Registry)]]]]]]) + +(def: module_id + 0) + +(template [<name> <base>] + [(type: #export <name> + (<base> Var Expression Expression))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type: #export (Generator i) + (-> Phase Archive i (Operation Expression))) + +(def: #export unit + (_.string /////synthesis.unit)) + +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} + body) + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} + code) + (do meta.monad + [runtime_id meta.count] + (macro.with_gensyms [g!_] + (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.var (~ (code.text (%.code runtime)))))] + (case declaration + (#.Left name) + (let [g!name (code.local_identifier name)] + (wrap (list (` (def: #export (~ g!name) + Var + (~ runtime_name))) + + (` (def: (~ (code.local_identifier (format "@" name))) + _.Computation + (_.define_constant (~ runtime_name) (~ code))))))) + + (#.Right [name inputs]) + (let [g!name (code.local_identifier name) + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` _.Expression)) + inputs)] + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) + (-> (~+ inputs_typesC) _.Computation) + (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) + + (` (def: (~ (code.local_identifier (format "@" name))) + _.Computation + (..with_vars [(~+ inputsC)] + (_.define_function (~ runtime_name) [(list (~+ inputsC)) #.None] + (~ code))))))))))))) + +(def: last_index + (-> Expression Computation) + (|>> _.length/1 (_.-/2 (_.int +1)))) + +(runtime: (tuple//left lefts tuple) + (with_vars [last_index_right] + (_.begin + (list (_.define_constant last_index_right (..last_index tuple)) + (_.if (_.>/2 lefts last_index_right) + ## No need for recursion + (_.vector-ref/2 tuple lefts) + ## Needs recursion + (tuple//left (_.-/2 last_index_right lefts) + (_.vector-ref/2 tuple last_index_right))))))) + +(runtime: (tuple//right lefts tuple) + (with_vars [last_index_right right_index @slice] + (_.begin + (list (_.define_constant last_index_right (..last_index tuple)) + (_.define_constant right_index (_.+/2 (_.int +1) lefts)) + (<| (_.if (_.=/2 last_index_right right_index) + (_.vector-ref/2 tuple right_index)) + (_.if (_.>/2 last_index_right right_index) + ## Needs recursion. + (tuple//right (_.-/2 last_index_right lefts) + (_.vector-ref/2 tuple last_index_right))) + (_.begin + (list (_.define_constant @slice (_.make-vector/1 (_.-/2 right_index (_.length/1 tuple)))) + (_.vector-copy!/5 @slice (_.int +0) tuple right_index (_.length/1 tuple)) + @slice)))) + ))) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Computation) + ($_ _.cons/2 + tag + last? + value)) + +(runtime: (sum//make tag last? value) + (variant' tag last? value)) + +(def: #export (variant [lefts right? value]) + (-> (Variant Expression) Computation) + (..sum//make (_.int (.int lefts)) (_.bool right?) value)) + +(runtime: (sum//get sum last? wanted_tag) + (with_vars [sum_tag sum_flag sum_value sum_temp sum_dump] + (let [no_match _.nil + test_recursion (_.if sum_flag + ## Must recurse. + (sum//get sum_value + last? + (|> wanted_tag (_.-/2 sum_tag))) + no_match)] + (<| (_.let (list [sum_tag (_.car/1 sum)] + [sum_temp (_.cdr/1 sum)])) + (_.let (list [sum_flag (_.car/1 sum_temp)] + [sum_value (_.cdr/1 sum_temp)])) + (_.if (_.=/2 wanted_tag sum_tag) + (_.if (_.eqv?/2 last? sum_flag) + sum_value + test_recursion)) + (_.if (_.</2 wanted_tag sum_tag) + test_recursion) + (_.if last? + (variant' (|> sum_tag (_.-/2 wanted_tag)) sum_flag sum_value)) + no_match)))) + +(def: runtime//adt + Computation + (_.begin (list @tuple//left + @tuple//right + @sum//get + @sum//make))) + +(def: #export none + Computation + (|> ..unit [0 #0] variant)) + +(def: #export some + (-> Expression Computation) + (|>> [1 #1] ..variant)) + +(def: #export left + (-> Expression Computation) + (|>> [0 #0] ..variant)) + +(def: #export right + (-> Expression Computation) + (|>> [1 #1] ..variant)) + +(runtime: (slice offset length list) + (<| (_.if (_.null?/1 list) + list) + (_.if (|> offset (_.>/2 (_.int +0))) + (slice (|> offset (_.-/2 (_.int +1))) + length + (_.cdr/1 list))) + (_.if (|> length (_.>/2 (_.int +0))) + (_.cons/2 (_.car/1 list) + (slice offset + (|> length (_.-/2 (_.int +1))) + (_.cdr/1 list)))) + _.nil)) + +(runtime: (lux//try op) + (with_vars [error] + (_.with_exception_handler + (_.lambda [(list error) #.None] + (..left error)) + (_.lambda [(list) #.None] + (..right (_.apply/* (list ..unit) op)))))) + +(runtime: (lux//program_args program_args) + (with_vars [@loop @input @output] + (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] + (_.if (_.null?/1 @input) + @output + (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) + (_.apply/2 @loop (_.reverse/1 program_args) ..none)))) + +(def: runtime//lux + Computation + (_.begin (list @lux//try + @lux//program_args))) + +(def: i64//+limit (_.manual "+9223372036854775807" + ## "+0x7FFFFFFFFFFFFFFF" + )) +(def: i64//-limit (_.manual "-9223372036854775808" + ## "-0x8000000000000000" + )) +(def: i64//+iteration (_.manual "+18446744073709551616" + ## "+0x10000000000000000" + )) +(def: i64//-iteration (_.manual "-18446744073709551616" + ## "-0x10000000000000000" + )) +(def: i64//+cap (_.manual "+9223372036854775808" + ## "+0x8000000000000000" + )) +(def: i64//-cap (_.manual "-9223372036854775809" + ## "-0x8000000000000001" + )) + +(runtime: (i64//64 input) + (with_vars [temp] + (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>] + [(_.if (|> input <scenario>) + (_.let (list [temp (_.remainder/2 <iteration> input)]) + (_.if (|> temp <scenario>) + (|> temp (_.-/2 <cap>) (_.+/2 <entrance>)) + temp)))] + + [(_.>/2 ..i64//+limit) ..i64//+iteration ..i64//+cap ..i64//-limit] + [(_.</2 ..i64//-limit) ..i64//-iteration ..i64//-cap ..i64//+limit] + )) + input)))) + +(runtime: (i64//left_shift param subject) + (|> subject + (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) param)) + ..i64//64)) + +(def: as_nat + (_.remainder/2 ..i64//+iteration)) + +(runtime: (i64//right_shift shift subject) + (_.let (list [shift (_.remainder/2 (_.int +64) shift)]) + (_.if (_.=/2 (_.int +0) shift) + subject + (|> subject + ..as_nat + (_.arithmetic-shift/2 (_.-/2 shift (_.int +0))))))) + +(template [<runtime> <host>] + [(runtime: (<runtime> left right) + (..i64//64 (<host> (..as_nat left) (..as_nat right))))] + + [i64//or _.bitwise-ior/2] + [i64//xor _.bitwise-xor/2] + [i64//and _.bitwise-and/2] + ) + +(runtime: (i64//division param subject) + (|> subject (_.//2 param) _.truncate/1 ..i64//64)) + +(def: runtime//i64 + Computation + (_.begin (list @i64//64 + @i64//left_shift + @i64//right_shift + @i64//or + @i64//xor + @i64//and + @i64//division))) + +(runtime: (f64//decode input) + (with_vars [@output] + (let [output_is_not_a_number? (_.not/1 (_.=/2 @output @output)) + input_is_not_a_number? (_.string=?/2 (_.string "+nan.0") input)] + (_.let (list [@output (_.string->number/1 input)]) + (_.if (_.and (list output_is_not_a_number? + (_.not/1 input_is_not_a_number?))) + ..none + (..some @output)))))) + +(def: runtime//f64 + Computation + (_.begin (list @f64//decode))) + +(runtime: (text//index offset sub text) + (with_vars [index] + (_.let (list [index (_.string-contains/3 text sub offset)]) + (_.if index + (..some index) + ..none)))) + +(runtime: (text//clip offset length text) + (_.substring/3 text offset (_.+/2 offset length))) + +(runtime: (text//char index text) + (_.char->integer/1 (_.string-ref/2 text index))) + +(def: runtime//text + (_.begin (list @text//index + @text//clip + @text//char))) + +(runtime: (array//write idx value array) + (_.begin (list (_.vector-set!/3 array idx value) + array))) + +(def: runtime//array + Computation + ($_ _.then + @array//write + )) + +(def: runtime + Computation + (_.begin (list @slice + runtime//lux + runtime//i64 + runtime//adt + runtime//f64 + runtime//text + runtime//array + ))) + +(def: #export generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! (%.nat ..module_id) ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row [(%.nat ..module_id) + (|> ..runtime + _.code + (\ utf8.codec encode))])]))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux new file mode 100644 index 000000000..50a8357f7 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux @@ -0,0 +1,40 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [data + [collection + ["." list]]] + [target + ["_" scheme (#+ Expression)]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." primitive] + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + ["//#" /// #_ + ["#." phase ("#\." monad)]]]]) + +(def: #export (tuple expression archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + #.Nil + (///////phase\wrap (//primitive.text /////synthesis.unit)) + + (#.Cons singletonS #.Nil) + (expression archive singletonS) + + _ + (|> elemsS+ + (monad.map ///////phase.monad (expression archive)) + (///////phase\map _.vector/*)))) + +(def: #export (variant expression archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (inc lefts) + lefts)] + (///////phase\map (|>> [tag right?] //runtime.variant) + (expression archive valueS)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis.lux new file mode 100644 index 000000000..47260c0fc --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis.lux @@ -0,0 +1,104 @@ +(.module: + [library + [lux (#- primitive) + [abstract + ["." monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." try]] + [data + ["." maybe] + [collection + ["." list ("#\." functor)] + ["." dictionary (#+ Dictionary)]]]]] + ["." / #_ + ["#." function] + ["#." case] + ["#." variable] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + ["#." analysis (#+ Analysis)] + ["/" synthesis (#+ Synthesis Phase)] + [/// + ["." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]) + +(def: (primitive analysis) + (-> ///analysis.Primitive /.Primitive) + (case analysis + #///analysis.Unit + (#/.Text /.unit) + + (^template [<analysis> <synthesis>] + [(<analysis> value) + (<synthesis> value)]) + ([#///analysis.Bit #/.Bit] + [#///analysis.Frac #/.F64] + [#///analysis.Text #/.Text]) + + (^template [<analysis> <synthesis>] + [(<analysis> value) + (<synthesis> (.i64 value))]) + ([#///analysis.Nat #/.I64] + [#///analysis.Int #/.I64] + [#///analysis.Rev #/.I64]))) + +(def: (optimization archive) + Phase + (function (optimization' analysis) + (case analysis + (#///analysis.Primitive analysis') + (phase\wrap (#/.Primitive (..primitive analysis'))) + + (#///analysis.Reference reference) + (phase\wrap (#/.Reference reference)) + + (#///analysis.Structure structure) + (/.with_currying? false + (case structure + (#///analysis.Variant variant) + (do phase.monad + [valueS (optimization' (get@ #///analysis.value variant))] + (wrap (/.variant (set@ #///analysis.value valueS variant)))) + + (#///analysis.Tuple tuple) + (|> tuple + (monad.map phase.monad optimization') + (phase\map (|>> /.tuple))))) + + (#///analysis.Case inputA branchesAB+) + (/.with_currying? false + (/case.synthesize optimization branchesAB+ archive inputA)) + + (^ (///analysis.no_op value)) + (optimization' value) + + (#///analysis.Apply _) + (/.with_currying? false + (/function.apply optimization archive analysis)) + + (#///analysis.Function environmentA bodyA) + (/function.abstraction optimization environmentA archive bodyA) + + (#///analysis.Extension name args) + (/.with_currying? false + (function (_ state) + (|> (//extension.apply archive optimization [name args]) + (phase.run' state) + (case> (#try.Success output) + (#try.Success output) + + (#try.Failure _) + (|> args + (monad.map phase.monad optimization') + (phase\map (|>> [name] #/.Extension)) + (phase.run' state)))))) + ))) + +(def: #export (phase archive analysis) + Phase + (do phase.monad + [synthesis (..optimization archive analysis)] + (phase.lift (/variable.optimization synthesis)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/case.lux new file mode 100644 index 000000000..02938eb7a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/case.lux @@ -0,0 +1,430 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + ["." monad (#+ do)]] + [control + [pipe (#+ when> new> case>)]] + [data + ["." product] + ["." bit ("#\." equivalence)] + ["." text ("#\." equivalence)] + [collection + ["." list ("#\." functor fold monoid)] + ["." set (#+ Set)]]] + [math + [number + ["n" nat] + ["." i64] + ["." frac ("#\." equivalence)]]]]] + ["." /// #_ + [// + ["#." analysis (#+ Pattern Match Analysis)] + ["/" synthesis (#+ Path Synthesis Operation Phase)] + [/// + ["#" phase ("#\." monad)] + ["#." reference + ["#/." variable (#+ Register Variable)]] + [meta + [archive (#+ Archive)]]]]]) + +(def: clean_up + (-> Path Path) + (|>> (#/.Seq #/.Pop))) + +(def: (path' pattern end? thenC) + (-> Pattern Bit (Operation Path) (Operation Path)) + (case pattern + (#///analysis.Simple simple) + (case simple + #///analysis.Unit + thenC + + (#///analysis.Bit when) + (///\map (function (_ then) + (#/.Bit_Fork when then #.None)) + thenC) + + (^template [<from> <to> <conversion>] + [(<from> test) + (///\map (function (_ then) + (<to> [(<conversion> test) then] (list))) + thenC)]) + ([#///analysis.Nat #/.I64_Fork .i64] + [#///analysis.Int #/.I64_Fork .i64] + [#///analysis.Rev #/.I64_Fork .i64] + [#///analysis.Frac #/.F64_Fork |>] + [#///analysis.Text #/.Text_Fork |>])) + + (#///analysis.Bind register) + (<| (\ ///.monad map (|>> (#/.Seq (#/.Bind register)))) + /.with_new_local + thenC) + + (#///analysis.Complex (#///analysis.Variant [lefts right? value_pattern])) + (<| (///\map (|>> (#/.Seq (#/.Access (#/.Side (if right? + (#.Right lefts) + (#.Left lefts))))))) + (path' value_pattern end?) + (when> [(new> (not end?) [])] [(///\map ..clean_up)]) + thenC) + + (#///analysis.Complex (#///analysis.Tuple tuple)) + (let [tuple::last (dec (list.size tuple))] + (list\fold (function (_ [tuple::lefts tuple::member] nextC) + (.case tuple::member + (#///analysis.Simple #///analysis.Unit) + nextC + + _ + (let [right? (n.= tuple::last tuple::lefts) + end?' (and end? right?)] + (<| (///\map (|>> (#/.Seq (#/.Access (#/.Member (if right? + (#.Right (dec tuple::lefts)) + (#.Left tuple::lefts))))))) + (path' tuple::member end?') + (when> [(new> (not end?') [])] [(///\map ..clean_up)]) + nextC)))) + thenC + (list.reverse (list.enumeration tuple)))) + )) + +(def: (path archive synthesize pattern bodyA) + (-> Archive Phase Pattern Analysis (Operation Path)) + (path' pattern true (///\map (|>> #/.Then) (synthesize archive bodyA)))) + +(def: (weave_branch weave equivalence [new_test new_then] [[old_test old_then] old_tail]) + (All [a] (-> (-> Path Path Path) (Equivalence a) [a Path] (/.Fork a Path) + (/.Fork a Path))) + (if (\ equivalence = new_test old_test) + [[old_test (weave new_then old_then)] old_tail] + [[old_test old_then] + (case old_tail + #.Nil + (list [new_test new_then]) + + (#.Cons old_cons) + (#.Cons (weave_branch weave equivalence [new_test new_then] old_cons)))])) + +(def: (weave_fork weave equivalence new_fork old_fork) + (All [a] (-> (-> Path Path Path) (Equivalence a) (/.Fork a Path) (/.Fork a Path) + (/.Fork a Path))) + (list\fold (..weave_branch weave equivalence) old_fork (#.Cons new_fork))) + +(def: (weave new old) + (-> Path Path Path) + (with_expansions [<default> (as_is (#/.Alt old new))] + (case [new old] + [_ + (#/.Alt old_left old_right)] + (#/.Alt old_left + (weave new old_right)) + + [(#/.Seq preN postN) + (#/.Seq preO postO)] + (case (weave preN preO) + (#/.Alt _) + <default> + + woven + (#/.Seq woven (weave postN postO))) + + [#/.Pop #/.Pop] + old + + [(#/.Bit_Fork new_when new_then new_else) + (#/.Bit_Fork old_when old_then old_else)] + (if (bit\= new_when old_when) + (#/.Bit_Fork old_when + (weave new_then old_then) + (case [new_else old_else] + [#.None #.None] + #.None + + (^or [(#.Some woven_then) #.None] + [#.None (#.Some woven_then)]) + (#.Some woven_then) + + [(#.Some new_else) (#.Some old_else)] + (#.Some (weave new_else old_else)))) + (#/.Bit_Fork old_when + (case new_else + #.None + old_then + + (#.Some new_else) + (weave new_else old_then)) + (#.Some (case old_else + #.None + new_then + + (#.Some old_else) + (weave new_then old_else))))) + + (^template [<tag> <equivalence>] + [[(<tag> new_fork) (<tag> old_fork)] + (<tag> (..weave_fork weave <equivalence> new_fork old_fork))]) + ([#/.I64_Fork i64.equivalence] + [#/.F64_Fork frac.equivalence] + [#/.Text_Fork text.equivalence]) + + (^template [<access> <side>] + [[(#/.Access (<access> (<side> newL))) + (#/.Access (<access> (<side> oldL)))] + (if (n.= newL oldL) + old + <default>)]) + ([#/.Side #.Left] + [#/.Side #.Right] + [#/.Member #.Left] + [#/.Member #.Right]) + + [(#/.Bind newR) (#/.Bind oldR)] + (if (n.= newR oldR) + old + <default>) + + _ + <default>))) + +(def: (get patterns @selection) + (-> (///analysis.Tuple ///analysis.Pattern) Register (List /.Member)) + (loop [lefts 0 + patterns patterns] + (with_expansions [<failure> (as_is (list)) + <continue> (as_is (recur (inc lefts) + tail)) + <member> (as_is (if (list.empty? tail) + (#.Right (dec lefts)) + (#.Left lefts)))] + (case patterns + #.Nil + <failure> + + (#.Cons head tail) + (case head + (#///analysis.Simple #///analysis.Unit) + <continue> + + (#///analysis.Bind register) + (if (n.= @selection register) + (list <member>) + <continue>) + + (#///analysis.Complex (#///analysis.Tuple sub_patterns)) + (case (get sub_patterns @selection) + #.Nil + <continue> + + sub_members + (list& <member> sub_members)) + + _ + <failure>))))) + +(def: #export (synthesize_case synthesize archive input [[headP headA] tailPA+]) + (-> Phase Archive Synthesis Match (Operation Synthesis)) + (do {! ///.monad} + [headSP (path archive synthesize headP headA) + tailSP+ (monad.map ! (product.uncurry (path archive synthesize)) tailPA+)] + (wrap (/.branch/case [input (list\fold weave headSP tailSP+)])))) + +(template: (!masking <variable> <output>) + [[(#///analysis.Bind <variable>) + (#///analysis.Reference (///reference.local <output>))] + (list)]) + +(def: #export (synthesize_let synthesize archive input @variable body) + (-> Phase Archive Synthesis Register Analysis (Operation Synthesis)) + (do ///.monad + [body (/.with_new_local + (synthesize archive body))] + (wrap (/.branch/let [input @variable body])))) + +(def: #export (synthesize_masking synthesize archive input @variable @output) + (-> Phase Archive Synthesis Register Register (Operation Synthesis)) + (if (n.= @variable @output) + (///\wrap input) + (..synthesize_let synthesize archive input @variable (#///analysis.Reference (///reference.local @output))))) + +(def: #export (synthesize_if synthesize archive test then else) + (-> Phase Archive Synthesis Analysis Analysis (Operation Synthesis)) + (do ///.monad + [then (synthesize archive then) + else (synthesize archive else)] + (wrap (/.branch/if [test then else])))) + +(template: (!get <patterns> <output>) + [[(///analysis.pattern/tuple <patterns>) + (#///analysis.Reference (///reference.local <output>))] + (.list)]) + +(def: #export (synthesize_get synthesize archive input patterns @member) + (-> Phase Archive Synthesis (///analysis.Tuple ///analysis.Pattern) Register (Operation Synthesis)) + (case (..get patterns @member) + #.Nil + (..synthesize_case synthesize archive input (!get patterns @member)) + + path + (case input + (^ (/.branch/get [sub_path sub_input])) + (///\wrap (/.branch/get [(list\compose path sub_path) sub_input])) + + _ + (///\wrap (/.branch/get [path input]))))) + +(def: #export (synthesize synthesize^ [headB tailB+] archive inputA) + (-> Phase Match Phase) + (do {! ///.monad} + [inputS (synthesize^ archive inputA)] + (case [headB tailB+] + (^ (!masking @variable @output)) + (..synthesize_masking synthesize^ archive inputS @variable @output) + + [[(#///analysis.Bind @variable) body] + #.Nil] + (..synthesize_let synthesize^ archive inputS @variable body) + + (^or (^ [[(///analysis.pattern/bit #1) then] + (list [(///analysis.pattern/bit #0) else])]) + (^ [[(///analysis.pattern/bit #1) then] + (list [(///analysis.pattern/unit) else])]) + + (^ [[(///analysis.pattern/bit #0) else] + (list [(///analysis.pattern/bit #1) then])]) + (^ [[(///analysis.pattern/bit #0) else] + (list [(///analysis.pattern/unit) then])])) + (..synthesize_if synthesize^ archive inputS then else) + + (^ (!get patterns @member)) + (..synthesize_get synthesize^ archive inputS patterns @member) + + match + (..synthesize_case synthesize^ archive inputS match)))) + +(def: #export (count_pops path) + (-> Path [Nat Path]) + (case path + (^ (/.path/seq #/.Pop path')) + (let [[pops post_pops] (count_pops path')] + [(inc pops) post_pops]) + + _ + [0 path])) + +(def: #export pattern_matching_error + "Invalid expression for pattern-matching.") + +(type: #export Storage + {#bindings (Set Register) + #dependencies (Set Variable)}) + +(def: empty + Storage + {#bindings (set.new n.hash) + #dependencies (set.new ///reference/variable.hash)}) + +## TODO: Use this to declare all local variables at the beginning of +## script functions. +## That way, it should be possible to do cheap "let" expressions, +## since the variable will exist beforehand, so no closure will need +## to be created for it. +## Apply this trick to JS, Python et al. +(def: #export (storage path) + (-> Path Storage) + (loop for_path + [path path + path_storage ..empty] + (case path + (^or #/.Pop (#/.Access Access)) + path_storage + + (^ (/.path/bind register)) + (update@ #bindings (set.add register) + path_storage) + + (#/.Bit_Fork _ default otherwise) + (|> (case otherwise + #.None + path_storage + + (#.Some otherwise) + (for_path otherwise path_storage)) + (for_path default)) + + (^or (#/.I64_Fork forks) + (#/.F64_Fork forks) + (#/.Text_Fork forks)) + (|> (#.Cons forks) + (list\map product.right) + (list\fold for_path path_storage)) + + (^or (^ (/.path/seq left right)) + (^ (/.path/alt left right))) + (list\fold for_path path_storage (list left right)) + + (^ (/.path/then bodyS)) + (loop for_synthesis + [bodyS bodyS + synthesis_storage path_storage] + (case bodyS + (^ (/.variant [lefts right? valueS])) + (for_synthesis valueS synthesis_storage) + + (^ (/.tuple members)) + (list\fold for_synthesis synthesis_storage members) + + (#/.Reference (#///reference.Variable (#///reference/variable.Local register))) + (if (set.member? (get@ #bindings synthesis_storage) register) + synthesis_storage + (update@ #dependencies (set.add (#///reference/variable.Local register)) synthesis_storage)) + + (#/.Reference (#///reference.Variable var)) + (update@ #dependencies (set.add var) synthesis_storage) + + (^ (/.function/apply [functionS argsS])) + (list\fold for_synthesis synthesis_storage (#.Cons functionS argsS)) + + (^ (/.function/abstraction [environment arity bodyS])) + (list\fold for_synthesis synthesis_storage environment) + + (^ (/.branch/case [inputS pathS])) + (update@ #dependencies + (set.union (get@ #dependencies (for_path pathS synthesis_storage))) + (for_synthesis inputS synthesis_storage)) + + (^ (/.branch/let [inputS register exprS])) + (update@ #dependencies + (set.union (|> synthesis_storage + (update@ #bindings (set.add register)) + (for_synthesis exprS) + (get@ #dependencies))) + (for_synthesis inputS synthesis_storage)) + + (^ (/.branch/if [testS thenS elseS])) + (list\fold for_synthesis synthesis_storage (list testS thenS elseS)) + + (^ (/.branch/get [access whole])) + (for_synthesis whole synthesis_storage) + + (^ (/.loop/scope [start initsS+ iterationS])) + (update@ #dependencies + (set.union (|> synthesis_storage + (update@ #bindings (set.union (|> initsS+ + list.enumeration + (list\map (|>> product.left (n.+ start))) + (set.from_list n.hash)))) + (for_synthesis iterationS) + (get@ #dependencies))) + (list\fold for_synthesis synthesis_storage initsS+)) + + (^ (/.loop/recur replacementsS+)) + (list\fold for_synthesis synthesis_storage replacementsS+) + + (#/.Extension [extension argsS]) + (list\fold for_synthesis synthesis_storage argsS) + + _ + synthesis_storage)) + ))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/function.lux new file mode 100644 index 000000000..2b0319266 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/function.lux @@ -0,0 +1,277 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)] + ["." enum]] + [control + [pipe (#+ case>)] + ["." exception (#+ exception:)]] + [data + ["." maybe ("#\." functor)] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor monoid fold)]]] + [math + [number + ["n" nat]]]]] + ["." // #_ + ["#." loop (#+ Transform)] + ["//#" /// #_ + ["#." analysis (#+ Environment Analysis)] + ["/" synthesis (#+ Path Abstraction Synthesis Operation Phase)] + [/// + [arity (#+ Arity)] + ["#." reference + ["#/." variable (#+ Register Variable)]] + ["." phase ("#\." monad)]]]]) + +(exception: #export (cannot_find_foreign_variable_in_environment {foreign Register} {environment (Environment Synthesis)}) + (exception.report + ["Foreign" (%.nat foreign)] + ["Environment" (exception.enumerate /.%synthesis environment)])) + +(def: arity_arguments + (-> Arity (List Synthesis)) + (|>> dec + (enum.range n.enum 1) + (list\map (|>> /.variable/local)))) + +(template: #export (self_reference) + (/.variable/local 0)) + +(def: (expanded_nested_self_reference arity) + (-> Arity Synthesis) + (/.function/apply [(..self_reference) (arity_arguments arity)])) + +(def: #export (apply phase) + (-> Phase Phase) + (function (_ archive exprA) + (let [[funcA argsA] (////analysis.application exprA)] + (do {! phase.monad} + [funcS (phase archive funcA) + argsS (monad.map ! (phase archive) argsA)] + (with_expansions [<apply> (as_is (/.function/apply [funcS argsS]))] + (case funcS + (^ (/.function/abstraction functionS)) + (if (n.= (get@ #/.arity functionS) + (list.size argsS)) + (do ! + [locals /.locals] + (wrap (|> functionS + (//loop.optimization true locals argsS) + (maybe\map (: (-> [Nat (List Synthesis) Synthesis] Synthesis) + (function (_ [start inits iteration]) + (case iteration + (^ (/.loop/scope [start' inits' output])) + (if (and (n.= start start') + (list.empty? inits')) + (/.loop/scope [start inits output]) + (/.loop/scope [start inits iteration])) + + _ + (/.loop/scope [start inits iteration]))))) + (maybe.default <apply>)))) + (wrap <apply>)) + + (^ (/.function/apply [funcS' argsS'])) + (wrap (/.function/apply [funcS' (list\compose argsS' argsS)])) + + _ + (wrap <apply>))))))) + +(def: (find_foreign environment register) + (-> (Environment Synthesis) Register (Operation Synthesis)) + (case (list.nth register environment) + (#.Some aliased) + (phase\wrap aliased) + + #.None + (phase.throw ..cannot_find_foreign_variable_in_environment [register environment]))) + +(def: (grow_path grow path) + (-> (-> Synthesis (Operation Synthesis)) Path (Operation Path)) + (case path + (#/.Bind register) + (phase\wrap (#/.Bind (inc register))) + + (^template [<tag>] + [(<tag> left right) + (do phase.monad + [left' (grow_path grow left) + right' (grow_path grow right)] + (wrap (<tag> left' right')))]) + ([#/.Alt] [#/.Seq]) + + (#/.Bit_Fork when then else) + (do {! phase.monad} + [then (grow_path grow then) + else (case else + (#.Some else) + (\ ! map (|>> #.Some) (grow_path grow else)) + + #.None + (wrap #.None))] + (wrap (#/.Bit_Fork when then else))) + + (^template [<tag>] + [(<tag> [[test then] elses]) + (do {! phase.monad} + [then (grow_path grow then) + elses (monad.map ! (function (_ [else_test else_then]) + (do ! + [else_then (grow_path grow else_then)] + (wrap [else_test else_then]))) + elses)] + (wrap (<tag> [[test then] elses])))]) + ([#/.I64_Fork] + [#/.F64_Fork] + [#/.Text_Fork]) + + (#/.Then thenS) + (|> thenS + grow + (phase\map (|>> #/.Then))) + + _ + (phase\wrap path))) + +(def: (grow environment expression) + (-> (Environment Synthesis) Synthesis (Operation Synthesis)) + (case expression + (#/.Structure structure) + (case structure + (#////analysis.Variant [lefts right? subS]) + (|> subS + (grow environment) + (phase\map (|>> [lefts right?] /.variant))) + + (#////analysis.Tuple membersS+) + (|> membersS+ + (monad.map phase.monad (grow environment)) + (phase\map (|>> /.tuple)))) + + (^ (..self_reference)) + (phase\wrap (/.function/apply [expression (list (/.variable/local 1))])) + + (#/.Reference reference) + (case reference + (#////reference.Variable variable) + (case variable + (#////reference/variable.Local register) + (phase\wrap (/.variable/local (inc register))) + + (#////reference/variable.Foreign register) + (..find_foreign environment register)) + + (#////reference.Constant constant) + (phase\wrap expression)) + + (#/.Control control) + (case control + (#/.Branch branch) + (case branch + (#/.Let [inputS register bodyS]) + (do phase.monad + [inputS' (grow environment inputS) + bodyS' (grow environment bodyS)] + (wrap (/.branch/let [inputS' (inc register) bodyS']))) + + (#/.If [testS thenS elseS]) + (do phase.monad + [testS' (grow environment testS) + thenS' (grow environment thenS) + elseS' (grow environment elseS)] + (wrap (/.branch/if [testS' thenS' elseS']))) + + (#/.Get members inputS) + (do phase.monad + [inputS' (grow environment inputS)] + (wrap (/.branch/get [members inputS']))) + + (#/.Case [inputS pathS]) + (do phase.monad + [inputS' (grow environment inputS) + pathS' (grow_path (grow environment) pathS)] + (wrap (/.branch/case [inputS' pathS'])))) + + (#/.Loop loop) + (case loop + (#/.Scope [start initsS+ iterationS]) + (do {! phase.monad} + [initsS+' (monad.map ! (grow environment) initsS+) + iterationS' (grow environment iterationS)] + (wrap (/.loop/scope [(inc start) initsS+' iterationS']))) + + (#/.Recur argumentsS+) + (|> argumentsS+ + (monad.map phase.monad (grow environment)) + (phase\map (|>> /.loop/recur)))) + + (#/.Function function) + (case function + (#/.Abstraction [_env _arity _body]) + (do {! phase.monad} + [_env' (monad.map ! + (|>> (case> (#/.Reference (#////reference.Variable (#////reference/variable.Foreign register))) + (..find_foreign environment register) + + captured + (grow environment captured))) + _env)] + (wrap (/.function/abstraction [_env' _arity _body]))) + + (#/.Apply funcS argsS+) + (do {! phase.monad} + [funcS (grow environment funcS) + argsS+ (monad.map ! (grow environment) argsS+)] + (wrap (/.function/apply (case funcS + (^ (/.function/apply [(..self_reference) pre_argsS+])) + [(..self_reference) + (list\compose pre_argsS+ argsS+)] + + _ + [funcS + argsS+])))))) + + (#/.Extension name argumentsS+) + (|> argumentsS+ + (monad.map phase.monad (grow environment)) + (phase\map (|>> (#/.Extension name)))) + + (#/.Primitive _) + (phase\wrap expression))) + +(def: #export (abstraction phase environment archive bodyA) + (-> Phase (Environment Analysis) Phase) + (do {! phase.monad} + [currying? /.currying? + environment (monad.map ! (phase archive) environment) + bodyS (/.with_currying? true + (/.with_locals 2 + (phase archive bodyA))) + abstraction (: (Operation Abstraction) + (case bodyS + (^ (/.function/abstraction [env' down_arity' bodyS'])) + (|> bodyS' + (grow env') + (\ ! map (function (_ body) + {#/.environment environment + #/.arity (inc down_arity') + #/.body body}))) + + _ + (wrap {#/.environment environment + #/.arity 1 + #/.body bodyS})))] + (wrap (if currying? + (/.function/abstraction abstraction) + (case (//loop.optimization false 1 (list) abstraction) + (#.Some [startL initsL bodyL]) + (/.function/abstraction {#/.environment environment + #/.arity (get@ #/.arity abstraction) + #/.body (/.loop/scope [startL initsL bodyL])}) + + #.None + (/.function/abstraction abstraction)))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/loop.lux new file mode 100644 index 000000000..ed5381e02 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/loop.lux @@ -0,0 +1,187 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [data + ["." maybe ("#\." monad)] + [collection + ["." list]]] + [math + [number + ["n" nat]]]]] + [//// + ["." analysis (#+ Environment)] + ["/" synthesis (#+ Path Abstraction Synthesis)] + [/// + [arity (#+ Arity)] + ["." reference + ["." variable (#+ Register Variable)]]]]) + +(type: #export (Transform a) + (-> a (Maybe a))) + +(def: #export (register_optimization offset) + (-> Register (-> Register Register)) + (|>> dec (n.+ offset))) + +(def: (path_optimization body_optimization offset) + (-> (Transform Synthesis) Register (Transform Path)) + (function (recur path) + (case path + (#/.Bind register) + (#.Some (#/.Bind (register_optimization offset register))) + + (^template [<tag>] + [(<tag> left right) + (do maybe.monad + [left' (recur left) + right' (recur right)] + (wrap (<tag> left' right')))]) + ([#/.Alt] [#/.Seq]) + + (#/.Bit_Fork when then else) + (do {! maybe.monad} + [then (recur then) + else (case else + (#.Some else) + (\ ! map (|>> #.Some) (recur else)) + + #.None + (wrap #.None))] + (wrap (#/.Bit_Fork when then else))) + + (^template [<tag>] + [(<tag> [[test then] elses]) + (do {! maybe.monad} + [then (recur then) + elses (monad.map ! (function (_ [else_test else_then]) + (do ! + [else_then (recur else_then)] + (wrap [else_test else_then]))) + elses)] + (wrap (<tag> [[test then] elses])))]) + ([#/.I64_Fork] + [#/.F64_Fork] + [#/.Text_Fork]) + + (#/.Then body) + (|> body + body_optimization + (maybe\map (|>> #/.Then))) + + _ + (#.Some path)))) + +(def: (body_optimization true_loop? offset scope_environment arity expr) + (-> Bit Register (Environment Synthesis) Arity (Transform Synthesis)) + (loop [return? true + expr expr] + (case expr + (#/.Primitive _) + (#.Some expr) + + (#/.Structure structure) + (case structure + (#analysis.Variant variant) + (do maybe.monad + [value' (|> variant (get@ #analysis.value) (recur false))] + (wrap (|> variant + (set@ #analysis.value value') + /.variant))) + + (#analysis.Tuple tuple) + (|> tuple + (monad.map maybe.monad (recur false)) + (maybe\map (|>> /.tuple)))) + + (#/.Reference reference) + (case reference + (^ (#reference.Variable (variable.self))) + (if true_loop? + #.None + (#.Some expr)) + + (^ (reference.constant constant)) + (#.Some expr) + + (^ (reference.local register)) + (#.Some (#/.Reference (reference.local (register_optimization offset register)))) + + (^ (reference.foreign register)) + (if true_loop? + (list.nth register scope_environment) + (#.Some expr))) + + (^ (/.branch/case [input path])) + (do maybe.monad + [input' (recur false input) + path' (path_optimization (recur return?) offset path)] + (wrap (|> path' [input'] /.branch/case))) + + (^ (/.branch/let [input register body])) + (do maybe.monad + [input' (recur false input) + body' (recur return? body)] + (wrap (/.branch/let [input' (register_optimization offset register) body']))) + + (^ (/.branch/if [input then else])) + (do maybe.monad + [input' (recur false input) + then' (recur return? then) + else' (recur return? else)] + (wrap (/.branch/if [input' then' else']))) + + (^ (/.branch/get [path record])) + (do maybe.monad + [record (recur false record)] + (wrap (/.branch/get [path record]))) + + (^ (/.loop/scope scope)) + (do {! maybe.monad} + [inits' (|> scope + (get@ #/.inits) + (monad.map ! (recur false))) + iteration' (recur return? (get@ #/.iteration scope))] + (wrap (/.loop/scope {#/.start (|> scope (get@ #/.start) (register_optimization offset)) + #/.inits inits' + #/.iteration iteration'}))) + + (^ (/.loop/recur args)) + (|> args + (monad.map maybe.monad (recur false)) + (maybe\map (|>> /.loop/recur))) + + (^ (/.function/abstraction [environment arity body])) + (do {! maybe.monad} + [environment' (monad.map ! (recur false) environment)] + (wrap (/.function/abstraction [environment' arity body]))) + + (^ (/.function/apply [abstraction arguments])) + (do {! maybe.monad} + [arguments' (monad.map maybe.monad (recur false) arguments)] + (with_expansions [<application> (as_is (do ! + [abstraction' (recur false abstraction)] + (wrap (/.function/apply [abstraction' arguments']))))] + (case abstraction + (^ (#/.Reference (#reference.Variable (variable.self)))) + (if (and return? + (n.= arity (list.size arguments))) + (wrap (/.loop/recur arguments')) + (if true_loop? + #.None + <application>)) + + _ + <application>))) + + (#/.Extension [name args]) + (|> args + (monad.map maybe.monad (recur false)) + (maybe\map (|>> [name] #/.Extension)))))) + +(def: #export (optimization true_loop? offset inits functionS) + (-> Bit Register (List Synthesis) Abstraction (Maybe [Register (List Synthesis) Synthesis])) + (|> (get@ #/.body functionS) + (body_optimization true_loop? offset (get@ #/.environment functionS) (get@ #/.arity functionS)) + (maybe\map (|>> [offset inits])))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/variable.lux new file mode 100644 index 000000000..07e7a54b9 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/variable.lux @@ -0,0 +1,443 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." maybe ("#\." functor)] + ["." text + ["%" format]] + [collection + ["." dictionary (#+ Dictionary)] + ["." list ("#\." functor fold)] + ["." set]]] + [math + [number + ["n" nat]]]]] + [//// + ["/" synthesis (#+ Path Synthesis)] + ["." analysis] + [/// + [arity (#+ Arity)] + ["." reference + ["." variable (#+ Register Variable)]]]]) + +(def: (prune redundant register) + (-> Register Register Register) + (if (n.> redundant register) + (dec register) + register)) + +(type: (Remover a) + (-> Register (-> a a))) + +(def: (remove_local_from_path remove_local redundant) + (-> (Remover Synthesis) (Remover Path)) + (function (recur path) + (case path + (#/.Seq (#/.Bind register) + post) + (if (n.= redundant register) + (recur post) + (#/.Seq (#/.Bind (if (n.> redundant register) + (dec register) + register)) + (recur post))) + + (^or (#/.Seq (#/.Access (#/.Member member)) + (#/.Seq (#/.Bind register) + post)) + ## This alternative form should never occur in practice. + ## Yet, it is "technically" possible to construct it. + (#/.Seq (#/.Seq (#/.Access (#/.Member member)) + (#/.Bind register)) + post)) + (if (n.= redundant register) + (recur post) + (#/.Seq (#/.Access (#/.Member member)) + (#/.Seq (#/.Bind (if (n.> redundant register) + (dec register) + register)) + (recur post)))) + + (^template [<tag>] + [(<tag> left right) + (<tag> (recur left) (recur right))]) + ([#/.Seq] + [#/.Alt]) + + (#/.Bit_Fork when then else) + (#/.Bit_Fork when (recur then) (maybe\map recur else)) + + (^template [<tag>] + [(<tag> [[test then] tail]) + (<tag> [[test (recur then)] + (list\map (function (_ [test' then']) + [test' (recur then')]) + tail)])]) + ([#/.I64_Fork] + [#/.F64_Fork] + [#/.Text_Fork]) + + (^or #/.Pop + (#/.Access _)) + path + + (#/.Bind register) + (undefined) + + (#/.Then then) + (#/.Then (remove_local redundant then)) + ))) + +(def: (remove_local_from_variable redundant variable) + (Remover Variable) + (case variable + (#variable.Local register) + (#variable.Local (..prune redundant register)) + + (#variable.Foreign register) + variable)) + +(def: (remove_local redundant) + (Remover Synthesis) + (function (recur synthesis) + (case synthesis + (#/.Primitive _) + synthesis + + (#/.Structure structure) + (#/.Structure (case structure + (#analysis.Variant [lefts right value]) + (#analysis.Variant [lefts right (recur value)]) + + (#analysis.Tuple tuple) + (#analysis.Tuple (list\map recur tuple)))) + + (#/.Reference reference) + (case reference + (#reference.Variable variable) + (/.variable (..remove_local_from_variable redundant variable)) + + (#reference.Constant constant) + synthesis) + + (#/.Control control) + (#/.Control (case control + (#/.Branch branch) + (#/.Branch (case branch + (#/.Let input register output) + (#/.Let (recur input) + (..prune redundant register) + (recur output)) + + (#/.If test then else) + (#/.If (recur test) (recur then) (recur else)) + + (#/.Get path record) + (#/.Get path (recur record)) + + (#/.Case input path) + (#/.Case (recur input) (remove_local_from_path remove_local redundant path)))) + + (#/.Loop loop) + (#/.Loop (case loop + (#/.Scope [start inits iteration]) + (#/.Scope [(..prune redundant start) + (list\map recur inits) + (recur iteration)]) + + (#/.Recur resets) + (#/.Recur (list\map recur resets)))) + + (#/.Function function) + (#/.Function (case function + (#/.Abstraction [environment arity body]) + (#/.Abstraction [(list\map recur environment) + arity + body]) + + (#/.Apply abstraction inputs) + (#/.Apply (recur abstraction) (list\map recur inputs)))))) + + (#/.Extension name inputs) + (#/.Extension name (list\map recur inputs))))) + +(type: Redundancy + (Dictionary Register Bit)) + +(def: initial + Redundancy + (dictionary.new n.hash)) + +(def: redundant! true) +(def: necessary! false) + +(def: (extended offset amount redundancy) + (-> Register Nat Redundancy [(List Register) Redundancy]) + (let [extension (|> amount list.indices (list\map (n.+ offset)))] + [extension + (list\fold (function (_ register redundancy) + (dictionary.put register ..necessary! redundancy)) + redundancy + extension)])) + +(def: (default arity) + (-> Arity Redundancy) + (product.right (..extended 0 (inc arity) ..initial))) + +(type: (Optimization a) + (-> [Redundancy a] (Try [Redundancy a]))) + +(def: (list_optimization optimization) + (All [a] (-> (Optimization a) (Optimization (List a)))) + (function (recur [redundancy values]) + (case values + #.Nil + (#try.Success [redundancy + values]) + + (#.Cons head tail) + (do try.monad + [[redundancy head] (optimization [redundancy head]) + [redundancy tail] (recur [redundancy tail])] + (wrap [redundancy + (#.Cons head tail)]))))) + +(template [<name>] + [(exception: #export (<name> {register Register}) + (exception.report + ["Register" (%.nat register)]))] + + [redundant_declaration] + [unknown_register] + ) + +(def: (declare register redundancy) + (-> Register Redundancy (Try Redundancy)) + (case (dictionary.get register redundancy) + #.None + (#try.Success (dictionary.put register ..redundant! redundancy)) + + (#.Some _) + (exception.throw ..redundant_declaration [register]))) + +(def: (observe register redundancy) + (-> Register Redundancy (Try Redundancy)) + (case (dictionary.get register redundancy) + #.None + (exception.throw ..unknown_register [register]) + + (#.Some _) + (#try.Success (dictionary.put register ..necessary! redundancy)))) + +(def: (format redundancy) + (%.Format Redundancy) + (|> redundancy + dictionary.entries + (list\map (function (_ [register redundant?]) + (%.format (%.nat register) ": " (%.bit redundant?)))) + (text.join_with ", "))) + +(def: (path_optimization optimization) + (-> (Optimization Synthesis) (Optimization Path)) + (function (recur [redundancy path]) + (case path + (^or #/.Pop + (#/.Access _)) + (#try.Success [redundancy + path]) + + (#/.Bit_Fork when then else) + (do {! try.monad} + [[redundancy then] (recur [redundancy then]) + [redundancy else] (case else + (#.Some else) + (\ ! map + (function (_ [redundancy else]) + [redundancy (#.Some else)]) + (recur [redundancy else])) + + #.None + (wrap [redundancy #.None]))] + (wrap [redundancy (#/.Bit_Fork when then else)])) + + (^template [<tag> <type>] + [(<tag> [[test then] elses]) + (do {! try.monad} + [[redundancy then] (recur [redundancy then]) + [redundancy elses] (..list_optimization (: (Optimization [<type> Path]) + (function (_ [redundancy [else_test else_then]]) + (do ! + [[redundancy else_then] (recur [redundancy else_then])] + (wrap [redundancy [else_test else_then]])))) + [redundancy elses])] + (wrap [redundancy (<tag> [[test then] elses])]))]) + ([#/.I64_Fork (I64 Any)] + [#/.F64_Fork Frac] + [#/.Text_Fork Text]) + + (#/.Bind register) + (do try.monad + [redundancy (..declare register redundancy)] + (wrap [redundancy + path])) + + (#/.Alt left right) + (do try.monad + [[redundancy left] (recur [redundancy left]) + [redundancy right] (recur [redundancy right])] + (wrap [redundancy (#/.Alt left right)])) + + (#/.Seq pre post) + (do try.monad + [#let [baseline (|> redundancy + dictionary.keys + (set.from_list n.hash))] + [redundancy pre] (recur [redundancy pre]) + #let [bindings (|> redundancy + dictionary.keys + (set.from_list n.hash) + (set.difference baseline))] + [redundancy post] (recur [redundancy post]) + #let [redundants (|> redundancy + dictionary.entries + (list.filter (function (_ [register redundant?]) + (and (set.member? bindings register) + redundant?))) + (list\map product.left))]] + (wrap [(list\fold dictionary.remove redundancy (set.to_list bindings)) + (|> redundants + (list.sort n.>) + (list\fold (..remove_local_from_path ..remove_local) (#/.Seq pre post)))])) + + (#/.Then then) + (do try.monad + [[redundancy then] (optimization [redundancy then])] + (wrap [redundancy (#/.Then then)])) + ))) + +(def: (optimization' [redundancy synthesis]) + (Optimization Synthesis) + (with_expansions [<no_op> (as_is (#try.Success [redundancy + synthesis]))] + (case synthesis + (#/.Primitive _) + <no_op> + + (#/.Structure structure) + (case structure + (#analysis.Variant [lefts right value]) + (do try.monad + [[redundancy value] (optimization' [redundancy value])] + (wrap [redundancy + (#/.Structure (#analysis.Variant [lefts right value]))])) + + (#analysis.Tuple tuple) + (do try.monad + [[redundancy tuple] (..list_optimization optimization' [redundancy tuple])] + (wrap [redundancy + (#/.Structure (#analysis.Tuple tuple))]))) + + (#/.Reference reference) + (case reference + (#reference.Variable variable) + (case variable + (#variable.Local register) + (do try.monad + [redundancy (..observe register redundancy)] + <no_op>) + + (#variable.Foreign register) + <no_op>) + + (#reference.Constant constant) + <no_op>) + + (#/.Control control) + (case control + (#/.Branch branch) + (case branch + (#/.Let input register output) + (do try.monad + [[redundancy input] (optimization' [redundancy input]) + redundancy (..declare register redundancy) + [redundancy output] (optimization' [redundancy output]) + #let [redundant? (|> redundancy + (dictionary.get register) + (maybe.default ..necessary!))]] + (wrap [(dictionary.remove register redundancy) + (#/.Control (if redundant? + (#/.Branch (#/.Case input + (#/.Seq #/.Pop + (#/.Then (..remove_local register output))))) + (#/.Branch (#/.Let input register output))))])) + + (#/.If test then else) + (do try.monad + [[redundancy test] (optimization' [redundancy test]) + [redundancy then] (optimization' [redundancy then]) + [redundancy else] (optimization' [redundancy else])] + (wrap [redundancy + (#/.Control (#/.Branch (#/.If test then else)))])) + + (#/.Get path record) + (do try.monad + [[redundancy record] (optimization' [redundancy record])] + (wrap [redundancy + (#/.Control (#/.Branch (#/.Get path record)))])) + + (#/.Case input path) + (do try.monad + [[redundancy input] (optimization' [redundancy input]) + [redundancy path] (..path_optimization optimization' [redundancy path])] + (wrap [redundancy + (#/.Control (#/.Branch (#/.Case input path)))]))) + + (#/.Loop loop) + (case loop + (#/.Scope [start inits iteration]) + (do try.monad + [[redundancy inits] (..list_optimization optimization' [redundancy inits]) + #let [[extension redundancy] (..extended start (list.size inits) redundancy)] + [redundancy iteration] (optimization' [redundancy iteration])] + (wrap [(list\fold dictionary.remove redundancy extension) + (#/.Control (#/.Loop (#/.Scope [start inits iteration])))])) + + (#/.Recur resets) + (do try.monad + [[redundancy resets] (..list_optimization optimization' [redundancy resets])] + (wrap [redundancy + (#/.Control (#/.Loop (#/.Recur resets)))]))) + + (#/.Function function) + (case function + (#/.Abstraction [environment arity body]) + (do {! try.monad} + [[redundancy environment] (..list_optimization optimization' [redundancy environment]) + [_ body] (optimization' [(..default arity) body])] + (wrap [redundancy + (#/.Control (#/.Function (#/.Abstraction [environment arity body])))])) + + (#/.Apply abstraction inputs) + (do try.monad + [[redundancy abstraction] (optimization' [redundancy abstraction]) + [redundancy inputs] (..list_optimization optimization' [redundancy inputs])] + (wrap [redundancy + (#/.Control (#/.Function (#/.Apply abstraction inputs)))])))) + + (#/.Extension name inputs) + (do try.monad + [[redundancy inputs] (..list_optimization optimization' [redundancy inputs])] + (wrap [redundancy + (#/.Extension name inputs)]))))) + +(def: #export optimization + (-> Synthesis (Try Synthesis)) + (|>> [..initial] + optimization' + (\ try.monad map product.right))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/program.lux b/stdlib/source/library/lux/tool/compiler/language/lux/program.lux new file mode 100644 index 000000000..f33831904 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/program.lux @@ -0,0 +1,57 @@ +(.module: + [library + [lux (#- Module) + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." maybe] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)]]]]] + [// + [generation (#+ Context)] + [/// + [meta + ["." archive (#+ Archive) + ["." descriptor (#+ Module)] + ["." artifact]]]]]) + +(type: #export (Program expression directive) + (-> Context expression directive)) + +(def: #export name + Text + "") + +(exception: #export (cannot-find-program {modules (List Module)}) + (exception.report + ["Modules" (exception.enumerate %.text modules)])) + +(def: #export (context archive) + (-> Archive (Try Context)) + (do {! try.monad} + [registries (|> archive + archive.archived + (monad.map ! + (function (_ module) + (do ! + [id (archive.id module archive) + [descriptor document] (archive.find module archive)] + (wrap [[module id] (get@ #descriptor.registry descriptor)])))))] + (case (list.one (function (_ [[module module-id] registry]) + (do maybe.monad + [program-id (artifact.remember ..name registry)] + (wrap [module-id program-id]))) + registries) + (#.Some program-context) + (wrap program-context) + + #.None + (|> registries + (list\map (|>> product.left product.left)) + (exception.throw ..cannot-find-program))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/syntax.lux b/stdlib/source/library/lux/tool/compiler/language/lux/syntax.lux new file mode 100644 index 000000000..e41cd0f79 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/syntax.lux @@ -0,0 +1,584 @@ +## This is LuxC's parser. +## It takes the source code of a Lux file in raw text form and +## extracts the syntactic structure of the code from it. +## It only produces Lux Code nodes, and thus removes any white-space +## and comments while processing its inputs. + +## Another important aspect of the parser is that it keeps track of +## its position within the input data. +## That is, the parser takes into account the line and column +## information in the input text (it doesn't really touch the +## file-name aspect of the location, leaving it intact in whatever +## base-line location it is given). + +## This particular piece of functionality is not located in one +## function, but it is instead scattered throughout several parsers, +## since the logic for how to update the location varies, depending on +## what is being parsed, and the rules involved. + +## You will notice that several parsers have a "where" parameter, that +## tells them the location position prior to the parser being run. +## They are supposed to produce some parsed output, alongside an +## updated location pointing to the end position, after the parser was run. + +## Lux Code nodes/tokens are annotated with location meta-data +## [file-name, line, column] to keep track of their provenance and +## location, which is helpful for documentation and debugging. +(.module: + [library + [lux #* + ["@" target] + [abstract + monad] + [control + ["." exception (#+ exception:)] + [parser + [text (#+ Offset)]]] + [data + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." list] + ["." dictionary (#+ Dictionary)]]] + [macro + ["." template]] + [math + [number + ["n" nat] + ["." int] + ["." rev] + ["." frac]]]]]) + +(template: (inline: <declaration> <type> <body>) + (for {@.python (def: <declaration> <type> <body>)} + (template: <declaration> <body>))) + +## TODO: Implement "lux syntax char case!" as a custom extension. +## That way, it should be possible to obtain the char without wrapping +## it into a java.lang.Long, thereby improving performance. + +## TODO: Make an extension to take advantage of java/lang/String::indexOf<int,int> +## to get better performance than the current "lux text index" extension. + +## TODO: Instead of always keeping a "where" location variable, keep the +## individual components (i.e. file, line and column) separate, so +## that updated the "where" only involved updating the components, and +## producing the locations only involved building them, without any need +## for pattern-matching and de-structuring. + +(type: Char + Nat) + +(template [<name> <extension> <diff>] + [(template: (<name> value) + (<extension> <diff> value))] + + [!inc "lux i64 +" 1] + [!inc/2 "lux i64 +" 2] + [!dec "lux i64 -" 1] + ) + +(template: (!clip from to text) + ("lux text clip" from (n.- from to) text)) + +(template [<name> <extension>] + [(template: (<name> reference subject) + (<extension> reference subject))] + + [!n/= "lux i64 ="] + [!i/< "lux i64 <"] + ) + +(template [<name> <extension>] + [(template: (<name> param subject) + (<extension> param subject))] + + [!n/+ "lux i64 +"] + [!n/- "lux i64 -"] + ) + +(type: #export Aliases + (Dictionary Text Text)) + +(def: #export no_aliases + Aliases + (dictionary.new text.hash)) + +(def: #export prelude + .prelude_module) + +(def: #export text_delimiter text.double_quote) + +(template [<char> <definition>] + [(def: #export <definition> <char>)] + + ## Form delimiters + ["(" open_form] + [")" close_form] + + ## Tuple delimiters + ["[" open_tuple] + ["]" close_tuple] + + ## Record delimiters + ["{" open_record] + ["}" close_record] + + ["#" sigil] + + ["," digit_separator] + + ["+" positive_sign] + ["-" negative_sign] + + ["." frac_separator] + + ## The parts of a name are separated by a single mark. + ## E.g. module.short. + ## Only one such mark may be used in an name, since there + ## can only be 2 parts to a name (the module [before the + ## mark], and the short [after the mark]). + ## There are also some extra rules regarding name syntax, + ## encoded in the parser. + ["." name_separator] + ) + +(exception: #export (end_of_file {module Text}) + (exception.report + ["Module" (%.text module)])) + +(def: amount_of_input_shown 64) + +(inline: (input_at start input) + (-> Offset Text Text) + (let [end (|> start (!n/+ amount_of_input_shown) (n.min ("lux text size" input)))] + (!clip start end input))) + +(exception: #export (unrecognized_input {[file line column] Location} {context Text} {input Text} {offset Offset}) + (exception.report + ["File" file] + ["Line" (%.nat line)] + ["Column" (%.nat column)] + ["Context" (%.text context)] + ["Input" (input_at offset input)])) + +(exception: #export (text_cannot_contain_new_lines {text Text}) + (exception.report + ["Text" (%.text text)])) + +(template: (!failure parser where offset source_code) + (#.Left [[where offset source_code] + (exception.construct ..unrecognized_input [where (%.name (name_of parser)) source_code offset])])) + +(template: (!end_of_file where offset source_code current_module) + (#.Left [[where offset source_code] + (exception.construct ..end_of_file current_module)])) + +(type: (Parser a) + (-> Source (Either [Source Text] [Source a]))) + +(template: (!with_char+ @source_code_size @source_code @offset @char @else @body) + (if (!i/< (:as Int @source_code_size) + (:as Int @offset)) + (let [@char ("lux text char" @offset @source_code)] + @body) + @else)) + +(template: (!with_char @source_code @offset @char @else @body) + (!with_char+ ("lux text size" @source_code) @source_code @offset @char @else @body)) + +(template: (!letE <binding> <computation> <body>) + (case <computation> + (#.Right <binding>) + <body> + + ## (#.Left error) + <<otherwise>> + (:assume <<otherwise>>))) + +(template: (!horizontal where offset source_code) + [(update@ #.column inc where) + (!inc offset) + source_code]) + +(inline: (!new_line where) + (-> Location Location) + (let [[where::file where::line where::column] where] + [where::file (!inc where::line) 0])) + +(inline: (!forward length where) + (-> Nat Location Location) + (let [[where::file where::line where::column] where] + [where::file where::line (!n/+ length where::column)])) + +(template: (!vertical where offset source_code) + [(!new_line where) + (!inc offset) + source_code]) + +(template [<name> <close> <tag>] + [(inline: (<name> parse where offset source_code) + (-> (Parser Code) Location Offset Text + (Either [Source Text] [Source Code])) + (loop [source (: Source [(!forward 1 where) offset source_code]) + stack (: (List Code) #.Nil)] + (case (parse source) + (#.Right [source' top]) + (recur source' (#.Cons top stack)) + + (#.Left [source' error]) + (if (is? <close> error) + (#.Right [source' + [where (<tag> (list.reverse stack))]]) + (#.Left [source' error])))))] + + ## Form and tuple syntax is mostly the same, differing only in the + ## delimiters involved. + ## They may have an arbitrary number of arbitrary Code nodes as elements. + [parse_form ..close_form #.Form] + [parse_tuple ..close_tuple #.Tuple] + ) + +(inline: (parse_record parse where offset source_code) + (-> (Parser Code) Location Offset Text + (Either [Source Text] [Source Code])) + (loop [source (: Source [(!forward 1 where) offset source_code]) + stack (: (List [Code Code]) #.Nil)] + (case (parse source) + (#.Right [sourceF field]) + (!letE [sourceFV value] (parse sourceF) + (recur sourceFV (#.Cons [field value] stack))) + + (#.Left [source' error]) + (if (is? ..close_record error) + (#.Right [source' + [where (#.Record (list.reverse stack))]]) + (#.Left [source' error]))))) + +(template: (!guarantee_no_new_lines where offset source_code content body) + (case ("lux text index" 0 (static text.new_line) content) + #.None + body + + g!_ + (#.Left [[where offset source_code] + (exception.construct ..text_cannot_contain_new_lines content)]))) + +(def: (parse_text where offset source_code) + (-> Location Offset Text (Either [Source Text] [Source Code])) + (case ("lux text index" offset (static ..text_delimiter) source_code) + (#.Some g!end) + (<| (let [g!content (!clip offset g!end source_code)]) + (!guarantee_no_new_lines where offset source_code g!content) + (#.Right [[(let [size (!n/- offset g!end)] + (update@ #.column (|>> (!n/+ size) (!n/+ 2)) where)) + (!inc g!end) + source_code] + [where + (#.Text g!content)]])) + + _ + (!failure ..parse_text where offset source_code))) + +(with_expansions [<digits> (as_is "0" "1" "2" "3" "4" "5" "6" "7" "8" "9") + <non_name_chars> (template [<char>] + [(~~ (static <char>))] + + [text.space] + [text.new_line] [text.carriage_return] + [..name_separator] + [..open_form] [..close_form] + [..open_tuple] [..close_tuple] + [..open_record] [..close_record] + [..text_delimiter] + [..sigil]) + <digit_separator> (static ..digit_separator)] + (template: (!if_digit? @char @then @else) + ("lux syntax char case!" @char + [[<digits>] + @then] + + ## else + @else)) + + (template: (!if_digit?+ @char @then @else_options @else) + (`` ("lux syntax char case!" @char + [[<digits> <digit_separator>] + @then + + (~~ (template.splice @else_options))] + + ## else + @else))) + + (`` (template: (!if_name_char?|tail @char @then @else) + ("lux syntax char case!" @char + [[<non_name_chars>] + @else] + + ## else + @then))) + + (`` (template: (!if_name_char?|head @char @then @else) + ("lux syntax char case!" @char + [[<non_name_chars> <digits>] + @else] + + ## else + @then))) + ) + +(template: (!number_output <source_code> <start> <end> <codec> <tag>) + (case (|> <source_code> + (!clip <start> <end>) + (text.replace_all ..digit_separator "") + (\ <codec> decode)) + (#.Right output) + (#.Right [[(let [[where::file where::line where::column] where] + [where::file where::line (!n/+ (!n/- <start> <end>) where::column)]) + <end> + <source_code>] + [where (<tag> output)]]) + + (#.Left error) + (#.Left [[where <start> <source_code>] + error]))) + +(def: no_exponent Offset 0) + +(with_expansions [<int_output> (as_is (!number_output source_code start end int.decimal #.Int)) + <frac_output> (as_is (!number_output source_code start end frac.decimal #.Frac)) + <failure> (!failure ..parse_frac where offset source_code) + <frac_separator> (static ..frac_separator) + <signs> (template [<sign>] + [(~~ (static <sign>))] + + [..positive_sign] + [..negative_sign])] + (inline: (parse_frac source_code//size start where offset source_code) + (-> Nat Nat Location Offset Text + (Either [Source Text] [Source Code])) + (loop [end offset + exponent (static ..no_exponent)] + (<| (!with_char+ source_code//size source_code end char/0 <frac_output>) + (!if_digit?+ char/0 + (recur (!inc end) exponent) + + [["e" "E"] + (if (is? (static ..no_exponent) exponent) + (<| (!with_char+ source_code//size source_code (!inc end) char/1 <failure>) + (`` ("lux syntax char case!" char/1 + [[<signs>] + (<| (!with_char+ source_code//size source_code (!n/+ 2 end) char/2 <failure>) + (!if_digit?+ char/2 + (recur (!n/+ 3 end) char/0) + [] + <failure>))] + ## else + <failure>))) + <frac_output>)] + + <frac_output>)))) + + (inline: (parse_signed source_code//size start where offset source_code) + (-> Nat Nat Location Offset Text + (Either [Source Text] [Source Code])) + (loop [end offset] + (<| (!with_char+ source_code//size source_code end char <int_output>) + (!if_digit?+ char + (recur (!inc end)) + + [[<frac_separator>] + (parse_frac source_code//size start where (!inc end) source_code)] + + <int_output>)))) + ) + +(template [<parser> <codec> <tag>] + [(inline: (<parser> source_code//size start where offset source_code) + (-> Nat Nat Location Offset Text + (Either [Source Text] [Source Code])) + (loop [g!end offset] + (<| (!with_char+ source_code//size source_code g!end g!char (!number_output source_code start g!end <codec> <tag>)) + (!if_digit?+ g!char + (recur (!inc g!end)) + [] + (!number_output source_code start g!end <codec> <tag>)))))] + + [parse_nat n.decimal #.Nat] + [parse_rev rev.decimal #.Rev] + ) + +(template: (!parse_signed source_code//size offset where source_code @aliases @end) + (<| (let [g!offset/1 (!inc offset)]) + (!with_char+ source_code//size source_code g!offset/1 g!char/1 @end) + (!if_digit? g!char/1 + (parse_signed source_code//size offset where (!inc/2 offset) source_code) + (!parse_full_name offset [where (!inc offset) source_code] where @aliases #.Identifier)))) + +(with_expansions [<output> (#.Right [[(update@ #.column (|>> (!n/+ (!n/- start end))) where) + end + source_code] + (!clip start end source_code)])] + (inline: (parse_name_part start where offset source_code) + (-> Nat Location Offset Text + (Either [Source Text] [Source Text])) + (let [source_code//size ("lux text size" source_code)] + (loop [end offset] + (<| (!with_char+ source_code//size source_code end char <output>) + (!if_name_char?|tail char + (recur (!inc end)) + <output>)))))) + +(template: (!parse_half_name @offset @char @module) + (!if_name_char?|head @char + (!letE [source' name] (..parse_name_part @offset where (!inc @offset) source_code) + (#.Right [source' [@module name]])) + (!failure ..!parse_half_name where @offset source_code))) + +(`` (def: (parse_short_name source_code//size current_module [where offset/0 source_code]) + (-> Nat Text (Parser Name)) + (<| (!with_char+ source_code//size source_code offset/0 char/0 + (!end_of_file where offset/0 source_code current_module)) + (if (!n/= (char (~~ (static ..name_separator))) char/0) + (<| (let [offset/1 (!inc offset/0)]) + (!with_char+ source_code//size source_code offset/1 char/1 + (!end_of_file where offset/1 source_code current_module)) + (!parse_half_name offset/1 char/1 current_module)) + (!parse_half_name offset/0 char/0 (static ..prelude)))))) + +(template: (!parse_short_name source_code//size @current_module @source @where @tag) + (!letE [source' name] (..parse_short_name source_code//size @current_module @source) + (#.Right [source' [@where (@tag name)]]))) + +(with_expansions [<simple> (as_is (#.Right [source' ["" simple]]))] + (`` (def: (parse_full_name aliases start source) + (-> Aliases Offset (Parser Name)) + (<| (!letE [source' simple] (let [[where offset source_code] source] + (..parse_name_part start where offset source_code))) + (let [[where' offset' source_code'] source']) + (!with_char source_code' offset' char/separator <simple>) + (if (!n/= (char (~~ (static ..name_separator))) char/separator) + (<| (let [offset'' (!inc offset')]) + (!letE [source'' complex] (..parse_name_part offset'' (!forward 1 where') offset'' source_code')) + (if ("lux text =" "" complex) + (let [[where offset source_code] source] + (!failure ..parse_full_name where offset source_code)) + (#.Right [source'' [(|> aliases + (dictionary.get simple) + (maybe.default simple)) + complex]]))) + <simple>))))) + +(template: (!parse_full_name @offset @source @where @aliases @tag) + (!letE [source' full_name] (..parse_full_name @aliases @offset @source) + (#.Right [source' [@where (@tag full_name)]]))) + +## TODO: Grammar macro for specifying syntax. +## (grammar: lux_grammar +## [expression ...] +## [form "(" [#* expression] ")"]) + +(with_expansions [<consume_1> (as_is where (!inc offset/0) source_code) + <move_1> (as_is [(!forward 1 where) (!inc offset/0) source_code]) + <move_2> (as_is [(!forward 1 where) (!inc/2 offset/0) source_code]) + <recur> (as_is (parse current_module aliases source_code//size)) + <horizontal_move> (as_is (recur (!horizontal where offset/0 source_code)))] + + (template: (!close closer) + (#.Left [<move_1> closer])) + + (def: #export (parse current_module aliases source_code//size) + (-> Text Aliases Nat (Parser Code)) + ## The "exec []" is only there to avoid function fusion. + ## This is to preserve the loop as much as possible and keep it tight. + (exec [] + (function (recur [where offset/0 source_code]) + (<| (!with_char+ source_code//size source_code offset/0 char/0 + (!end_of_file where offset/0 source_code current_module)) + (with_expansions [<composites> (template [<open> <close> <parser>] + [[(~~ (static <open>))] + (<parser> <recur> <consume_1>) + + [(~~ (static <close>))] + (!close <close>)] + + [..open_form ..close_form parse_form] + [..open_tuple ..close_tuple parse_tuple] + [..open_record ..close_record parse_record] + )] + (`` ("lux syntax char case!" char/0 + [[(~~ (static text.space)) + (~~ (static text.carriage_return))] + <horizontal_move> + + ## New line + [(~~ (static text.new_line))] + (recur (!vertical where offset/0 source_code)) + + <composites> + + ## Text + [(~~ (static ..text_delimiter))] + (parse_text where (!inc offset/0) source_code) + + ## Special code + [(~~ (static ..sigil))] + (<| (let [offset/1 (!inc offset/0)]) + (!with_char+ source_code//size source_code offset/1 char/1 + (!end_of_file where offset/1 source_code current_module)) + ("lux syntax char case!" char/1 + [[(~~ (static ..name_separator))] + (!parse_short_name source_code//size current_module <move_2> where #.Tag) + + ## Single_line comment + [(~~ (static ..sigil))] + (case ("lux text index" (!inc offset/1) (static text.new_line) source_code) + (#.Some end) + (recur (!vertical where end source_code)) + + _ + (!end_of_file where offset/1 source_code current_module)) + + (~~ (template [<char> <bit>] + [[<char>] + (#.Right [[(update@ #.column (|>> !inc/2) where) + (!inc offset/1) + source_code] + [where (#.Bit <bit>)]])] + + ["0" #0] + ["1" #1]))] + + ## else + (!if_name_char?|head char/1 + ## Tag + (!parse_full_name offset/1 <move_2> where aliases #.Tag) + (!failure ..parse where offset/0 source_code)))) + + ## Coincidentally (= ..name_separator ..frac_separator) + [(~~ (static ..name_separator)) + ## (~~ (static ..frac_separator)) + ] + (<| (let [offset/1 (!inc offset/0)]) + (!with_char+ source_code//size source_code offset/1 char/1 + (!end_of_file where offset/1 source_code current_module)) + (!if_digit? char/1 + (parse_rev source_code//size offset/0 where (!inc offset/1) source_code) + (!parse_short_name source_code//size current_module [where offset/1 source_code] where #.Identifier))) + + [(~~ (static ..positive_sign)) + (~~ (static ..negative_sign))] + (!parse_signed source_code//size offset/0 where source_code aliases + (!end_of_file where offset/0 source_code current_module))] + + ## else + (!if_digit? char/0 + ## Natural number + (parse_nat source_code//size offset/0 where (!inc offset/0) source_code) + ## Identifier + (!parse_full_name offset/0 [<consume_1>] where aliases #.Identifier)) + ))) + ))) + )) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/synthesis.lux new file mode 100644 index 000000000..cec608916 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/synthesis.lux @@ -0,0 +1,809 @@ +(.module: + [library + [lux (#- i64 Scope) + [abstract + [monad (#+ do)] + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] + [control + [pipe (#+ case>)] + ["." exception (#+ exception:)]] + [data + ["." sum] + ["." product] + ["." maybe] + ["." bit ("#\." equivalence)] + ["." text ("#\." equivalence) + ["%" format (#+ Format format)]] + [collection + ["." list ("#\." functor)] + ["." dictionary (#+ Dictionary)]]] + [math + [number + ["." i64] + ["n" nat] + ["i" int] + ["f" frac]]]]] + [// + ["." analysis (#+ Environment Composite Analysis)] + [phase + ["." extension (#+ Extension)]] + [/// + [arity (#+ Arity)] + ["." phase] + ["." reference (#+ Reference) + ["." variable (#+ Register Variable)]]]]) + +(type: #export Resolver + (Dictionary Variable Variable)) + +(type: #export State + {#locals Nat + ## https://en.wikipedia.org/wiki/Currying + #currying? Bit}) + +(def: #export fresh_resolver + Resolver + (dictionary.new variable.hash)) + +(def: #export init + State + {#locals 0 + #currying? false}) + +(type: #export Primitive + (#Bit Bit) + (#I64 (I64 Any)) + (#F64 Frac) + (#Text Text)) + +(type: #export Side + (Either Nat Nat)) + +(type: #export Member + (Either Nat Nat)) + +(type: #export Access + (#Side Side) + (#Member Member)) + +(type: #export (Fork value next) + [[value next] (List [value next])]) + +(type: #export (Path' s) + #Pop + (#Access Access) + (#Bind Register) + (#Bit_Fork Bit (Path' s) (Maybe (Path' s))) + (#I64_Fork (Fork (I64 Any) (Path' s))) + (#F64_Fork (Fork Frac (Path' s))) + (#Text_Fork (Fork Text (Path' s))) + (#Alt (Path' s) (Path' s)) + (#Seq (Path' s) (Path' s)) + (#Then s)) + +(type: #export (Abstraction' s) + {#environment (Environment s) + #arity Arity + #body s}) + +(type: #export (Apply' s) + {#function s + #arguments (List s)}) + +(type: #export (Branch s) + (#Let s Register s) + (#If s s s) + (#Get (List Member) s) + (#Case s (Path' s))) + +(type: #export (Scope s) + {#start Register + #inits (List s) + #iteration s}) + +(type: #export (Loop s) + (#Scope (Scope s)) + (#Recur (List s))) + +(type: #export (Function s) + (#Abstraction (Abstraction' s)) + (#Apply s (List s))) + +(type: #export (Control s) + (#Branch (Branch s)) + (#Loop (Loop s)) + (#Function (Function s))) + +(type: #export #rec Synthesis + (#Primitive Primitive) + (#Structure (Composite Synthesis)) + (#Reference Reference) + (#Control (Control Synthesis)) + (#Extension (Extension Synthesis))) + +(template [<special> <general>] + [(type: #export <special> + (<general> ..State Analysis Synthesis))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(type: #export Path + (Path' Synthesis)) + +(def: #export path/pop + Path + #Pop) + +(template [<name> <kind>] + [(template: #export (<name> content) + (.<| #..Access + <kind> + content))] + + [path/side #..Side] + [path/member #..Member] + ) + +(template [<name> <kind> <side>] + [(template: #export (<name> content) + (.<| #..Access + <kind> + <side> + content))] + + [side/left #..Side #.Left] + [side/right #..Side #.Right] + [member/left #..Member #.Left] + [member/right #..Member #.Right] + ) + +(template [<name> <tag>] + [(template: #export (<name> content) + (<tag> content))] + + [path/bind #..Bind] + [path/then #..Then] + ) + +(template [<name> <tag>] + [(template: #export (<name> left right) + (<tag> [left right]))] + + [path/alt #..Alt] + [path/seq #..Seq] + ) + +(type: #export Abstraction + (Abstraction' Synthesis)) + +(type: #export Apply + (Apply' Synthesis)) + +(def: #export unit Text "") + +(template [<with> <query> <tag> <type>] + [(def: #export (<with> value) + (-> <type> (All [a] (-> (Operation a) (Operation a)))) + (extension.temporary (set@ <tag> value))) + + (def: #export <query> + (Operation <type>) + (extension.read (get@ <tag>)))] + + [with_locals locals #locals Nat] + [with_currying? currying? #currying? Bit] + ) + +(def: #export with_new_local + (All [a] (-> (Operation a) (Operation a))) + (<<| (do phase.monad + [locals ..locals]) + (..with_locals (inc locals)))) + +(template [<name> <tag>] + [(template: #export (<name> content) + (#..Primitive (<tag> content)))] + + [bit #..Bit] + [i64 #..I64] + [f64 #..F64] + [text #..Text] + ) + +(template [<name> <tag>] + [(template: #export (<name> content) + (<| #..Structure + <tag> + content))] + + [variant #analysis.Variant] + [tuple #analysis.Tuple] + ) + +(template [<name> <tag>] + [(template: #export (<name> content) + (.<| #..Reference + <tag> + content))] + + [variable reference.variable] + [constant reference.constant] + [variable/local reference.local] + [variable/foreign reference.foreign] + ) + +(template [<name> <family> <tag>] + [(template: #export (<name> content) + (.<| #..Control + <family> + <tag> + content))] + + [branch/case #..Branch #..Case] + [branch/let #..Branch #..Let] + [branch/if #..Branch #..If] + [branch/get #..Branch #..Get] + + [loop/recur #..Loop #..Recur] + [loop/scope #..Loop #..Scope] + + [function/abstraction #..Function #..Abstraction] + [function/apply #..Function #..Apply] + ) + +(def: #export (%path' %then value) + (All [a] (-> (Format a) (Format (Path' a)))) + (case value + #Pop + "_" + + (#Bit_Fork when then else) + (format "(?" + " " (%.bit when) " " (%path' %then then) + (case else + (#.Some else) + (format " " (%.bit (not when)) " " (%path' %then else)) + + #.None + "") + ")") + + (^template [<tag> <format>] + [(<tag> cons) + (|> (#.Cons cons) + (list\map (function (_ [test then]) + (format (<format> test) " " (%path' %then then)))) + (text.join_with " ") + (text.enclose ["(? " ")"]))]) + ([#I64_Fork (|>> .int %.int)] + [#F64_Fork %.frac] + [#Text_Fork %.text]) + + (#Access access) + (case access + (#Side side) + (case side + (#.Left lefts) + (format "(" (%.nat lefts) " #0" ")") + + (#.Right lefts) + (format "(" (%.nat lefts) " #1" ")")) + + (#Member member) + (case member + (#.Left lefts) + (format "[" (%.nat lefts) " #0" "]") + + (#.Right lefts) + (format "[" (%.nat lefts) " #1" "]"))) + + (#Bind register) + (format "(@ " (%.nat register) ")") + + (#Alt left right) + (format "(| " (%path' %then left) " " (%path' %then right) ")") + + (#Seq left right) + (format "(& " (%path' %then left) " " (%path' %then right) ")") + + (#Then then) + (|> (%then then) + (text.enclose ["(! " ")"])))) + +(def: #export (%synthesis value) + (Format Synthesis) + (case value + (#Primitive primitive) + (case primitive + (^template [<pattern> <format>] + [(<pattern> value) + (<format> value)]) + ([#Bit %.bit] + [#F64 %.frac] + [#Text %.text]) + + (#I64 value) + (%.int (.int value))) + + (#Structure structure) + (case structure + (#analysis.Variant [lefts right? content]) + (|> (%synthesis content) + (format (%.nat lefts) " " (%.bit right?) " ") + (text.enclose ["(" ")"])) + + (#analysis.Tuple members) + (|> members + (list\map %synthesis) + (text.join_with " ") + (text.enclose ["[" "]"]))) + + (#Reference reference) + (reference.format reference) + + (#Control control) + (case control + (#Function function) + (case function + (#Abstraction [environment arity body]) + (let [environment' (|> environment + (list\map %synthesis) + (text.join_with " ") + (text.enclose ["[" "]"]))] + (|> (format environment' " " (%.nat arity) " " (%synthesis body)) + (text.enclose ["(#function " ")"]))) + + (#Apply func args) + (|> args + (list\map %synthesis) + (text.join_with " ") + (format (%synthesis func) " ") + (text.enclose ["(" ")"]))) + + (#Branch branch) + (case branch + (#Let input register body) + (|> (format (%.nat register) " " (%synthesis input) " " (%synthesis body)) + (text.enclose ["(#let " ")"])) + + (#If test then else) + (|> (format (%synthesis test) " " (%synthesis then) " " (%synthesis else)) + (text.enclose ["(#if " ")"])) + + (#Get members record) + (|> (format (%.list (%path' %synthesis) + (list\map (|>> #Member #Access) members)) + " " (%synthesis record)) + (text.enclose ["(#get " ")"])) + + (#Case input path) + (|> (format (%synthesis input) " " (%path' %synthesis path)) + (text.enclose ["(#case " ")"]))) + + (#Loop loop) + (case loop + (#Scope scope) + (|> (format (%.nat (get@ #start scope)) + " " (|> (get@ #inits scope) + (list\map %synthesis) + (text.join_with " ") + (text.enclose ["[" "]"])) + " " (%synthesis (get@ #iteration scope))) + (text.enclose ["(#loop " ")"])) + + (#Recur args) + (|> args + (list\map %synthesis) + (text.join_with " ") + (text.enclose ["(#recur " ")"])))) + + (#Extension [name args]) + (|> (list\map %synthesis args) + (text.join_with " ") + (format (%.text name) " ") + (text.enclose ["(" ")"])))) + +(def: #export %path + (Format Path) + (%path' %synthesis)) + +(implementation: #export primitive_equivalence + (Equivalence Primitive) + + (def: (= reference sample) + (case [reference sample] + (^template [<tag> <eq> <format>] + [[(<tag> reference') (<tag> sample')] + (<eq> reference' sample')]) + ([#Bit bit\= %.bit] + [#F64 f.= %.frac] + [#Text text\= %.text]) + + [(#I64 reference') (#I64 sample')] + (i.= (.int reference') (.int sample')) + + _ + false))) + +(implementation: primitive_hash + (Hash Primitive) + + (def: &equivalence ..primitive_equivalence) + + (def: hash + (|>> (case> (^template [<tag> <hash>] + [(<tag> value') + (\ <hash> hash value')]) + ([#Bit bit.hash] + [#F64 f.hash] + [#Text text.hash] + [#I64 i64.hash]))))) + +(def: side_equivalence + (Equivalence Side) + (sum.equivalence n.equivalence n.equivalence)) + +(def: member_equivalence + (Equivalence Member) + (sum.equivalence n.equivalence n.equivalence)) + +(def: member_hash + (Hash Member) + (sum.hash n.hash n.hash)) + +(implementation: #export access_equivalence + (Equivalence Access) + + (def: (= reference sample) + (case [reference sample] + (^template [<tag> <equivalence>] + [[(<tag> reference) (<tag> sample)] + (\ <equivalence> = reference sample)]) + ([#Side ..side_equivalence] + [#Member ..member_equivalence]) + + _ + false))) + +(implementation: access_hash + (Hash Access) + + (def: &equivalence ..access_equivalence) + + (def: (hash value) + (let [sub_hash (sum.hash n.hash n.hash)] + (case value + (^template [<tag>] + [(<tag> value) + (\ sub_hash hash value)]) + ([#Side] + [#Member]))))) + +(implementation: #export (path'_equivalence equivalence) + (All [a] (-> (Equivalence a) (Equivalence (Path' a)))) + + (def: (= reference sample) + (case [reference sample] + [#Pop #Pop] + true + + [(#Bit_Fork reference_when reference_then reference_else) + (#Bit_Fork sample_when sample_then sample_else)] + (and (bit\= reference_when sample_when) + (= reference_then sample_then) + (\ (maybe.equivalence =) = reference_else sample_else)) + + (^template [<tag> <equivalence>] + [[(<tag> reference_cons) + (<tag> sample_cons)] + (\ (list.equivalence (product.equivalence <equivalence> =)) = + (#.Cons reference_cons) + (#.Cons sample_cons))]) + ([#I64_Fork i64.equivalence] + [#F64_Fork f.equivalence] + [#Text_Fork text.equivalence]) + + (^template [<tag> <equivalence>] + [[(<tag> reference') (<tag> sample')] + (\ <equivalence> = reference' sample')]) + ([#Access ..access_equivalence] + [#Then equivalence]) + + [(#Bind reference') (#Bind sample')] + (n.= reference' sample') + + (^template [<tag>] + [[(<tag> leftR rightR) (<tag> leftS rightS)] + (and (= leftR leftS) + (= rightR rightS))]) + ([#Alt] + [#Seq]) + + _ + false))) + +(implementation: (path'_hash super) + (All [a] (-> (Hash a) (Hash (Path' a)))) + + (def: &equivalence + (..path'_equivalence (\ super &equivalence))) + + (def: (hash value) + (case value + #Pop + 2 + + (#Access access) + (n.* 3 (\ ..access_hash hash access)) + + (#Bind register) + (n.* 5 (\ n.hash hash register)) + + (#Bit_Fork when then else) + ($_ n.* 7 + (\ bit.hash hash when) + (hash then) + (\ (maybe.hash (path'_hash super)) hash else)) + + (^template [<factor> <tag> <hash>] + [(<tag> cons) + (let [case_hash (product.hash <hash> + (path'_hash super)) + cons_hash (product.hash case_hash (list.hash case_hash))] + (n.* <factor> (\ cons_hash hash cons)))]) + ([11 #I64_Fork i64.hash] + [13 #F64_Fork f.hash] + [17 #Text_Fork text.hash]) + + (^template [<factor> <tag>] + [(<tag> fork) + (let [recur_hash (path'_hash super) + fork_hash (product.hash recur_hash recur_hash)] + (n.* <factor> (\ fork_hash hash fork)))]) + ([19 #Alt] + [23 #Seq]) + + (#Then body) + (n.* 29 (\ super hash body)) + ))) + +(implementation: (branch_equivalence (^open "\.")) + (All [a] (-> (Equivalence a) (Equivalence (Branch a)))) + + (def: (= reference sample) + (case [reference sample] + [(#Let [reference_input reference_register reference_body]) + (#Let [sample_input sample_register sample_body])] + (and (\= reference_input sample_input) + (n.= reference_register sample_register) + (\= reference_body sample_body)) + + [(#If [reference_test reference_then reference_else]) + (#If [sample_test sample_then sample_else])] + (and (\= reference_test sample_test) + (\= reference_then sample_then) + (\= reference_else sample_else)) + + [(#Get [reference_path reference_record]) + (#Get [sample_path sample_record])] + (and (\ (list.equivalence ..member_equivalence) = reference_path sample_path) + (\= reference_record sample_record)) + + [(#Case [reference_input reference_path]) + (#Case [sample_input sample_path])] + (and (\= reference_input sample_input) + (\ (path'_equivalence \=) = reference_path sample_path)) + + _ + false))) + +(implementation: (branch_hash super) + (All [a] (-> (Hash a) (Hash (Branch a)))) + + (def: &equivalence + (..branch_equivalence (\ super &equivalence))) + + (def: (hash value) + (case value + (#Let [input register body]) + ($_ n.* 2 + (\ super hash input) + (\ n.hash hash register) + (\ super hash body)) + + (#If [test then else]) + ($_ n.* 3 + (\ super hash test) + (\ super hash then) + (\ super hash else)) + + (#Get [path record]) + ($_ n.* 5 + (\ (list.hash ..member_hash) hash path) + (\ super hash record)) + + (#Case [input path]) + ($_ n.* 7 + (\ super hash input) + (\ (..path'_hash super) hash path)) + ))) + +(implementation: (loop_equivalence (^open "\.")) + (All [a] (-> (Equivalence a) (Equivalence (Loop a)))) + + (def: (= reference sample) + (case [reference sample] + [(#Scope [reference_start reference_inits reference_iteration]) + (#Scope [sample_start sample_inits sample_iteration])] + (and (n.= reference_start sample_start) + (\ (list.equivalence \=) = reference_inits sample_inits) + (\= reference_iteration sample_iteration)) + + [(#Recur reference) (#Recur sample)] + (\ (list.equivalence \=) = reference sample) + + _ + false))) + +(implementation: (loop_hash super) + (All [a] (-> (Hash a) (Hash (Loop a)))) + + (def: &equivalence + (..loop_equivalence (\ super &equivalence))) + + (def: (hash value) + (case value + (#Scope [start inits iteration]) + ($_ n.* 2 + (\ n.hash hash start) + (\ (list.hash super) hash inits) + (\ super hash iteration)) + + (#Recur resets) + ($_ n.* 3 + (\ (list.hash super) hash resets)) + ))) + +(implementation: (function_equivalence (^open "\.")) + (All [a] (-> (Equivalence a) (Equivalence (Function a)))) + + (def: (= reference sample) + (case [reference sample] + [(#Abstraction [reference_environment reference_arity reference_body]) + (#Abstraction [sample_environment sample_arity sample_body])] + (and (\ (list.equivalence \=) = reference_environment sample_environment) + (n.= reference_arity sample_arity) + (\= reference_body sample_body)) + + [(#Apply [reference_abstraction reference_arguments]) + (#Apply [sample_abstraction sample_arguments])] + (and (\= reference_abstraction sample_abstraction) + (\ (list.equivalence \=) = reference_arguments sample_arguments)) + + _ + false))) + +(implementation: (function_hash super) + (All [a] (-> (Hash a) (Hash (Function a)))) + + (def: &equivalence + (..function_equivalence (\ super &equivalence))) + + (def: (hash value) + (case value + (#Abstraction [environment arity body]) + ($_ n.* 2 + (\ (list.hash super) hash environment) + (\ n.hash hash arity) + (\ super hash body)) + + (#Apply [abstraction arguments]) + ($_ n.* 3 + (\ super hash abstraction) + (\ (list.hash super) hash arguments)) + ))) + +(implementation: (control_equivalence (^open "\.")) + (All [a] (-> (Equivalence a) (Equivalence (Control a)))) + + (def: (= reference sample) + (case [reference sample] + (^template [<tag> <equivalence>] + [[(<tag> reference) (<tag> sample)] + (\ (<equivalence> \=) = reference sample)]) + ([#Branch ..branch_equivalence] + [#Loop ..loop_equivalence] + [#Function ..function_equivalence]) + + _ + false))) + +(implementation: (control_hash super) + (All [a] (-> (Hash a) (Hash (Control a)))) + + (def: &equivalence + (..control_equivalence (\ super &equivalence))) + + (def: (hash value) + (case value + (^template [<factor> <tag> <hash>] + [(<tag> value) + (n.* <factor> (\ (<hash> super) hash value))]) + ([2 #Branch ..branch_hash] + [3 #Loop ..loop_hash] + [5 #Function ..function_hash]) + ))) + +(implementation: #export equivalence + (Equivalence Synthesis) + + (def: (= reference sample) + (case [reference sample] + (^template [<tag> <equivalence>] + [[(<tag> reference') (<tag> sample')] + (\ <equivalence> = reference' sample')]) + ([#Primitive ..primitive_equivalence] + [#Structure (analysis.composite_equivalence =)] + [#Reference reference.equivalence] + [#Control (control_equivalence =)] + [#Extension (extension.equivalence =)]) + + _ + false))) + +(def: #export path_equivalence + (Equivalence Path) + (path'_equivalence equivalence)) + +(implementation: #export hash + (Hash Synthesis) + + (def: &equivalence ..equivalence) + + (def: (hash value) + (let [recur_hash [..equivalence hash]] + (case value + (^template [<tag> <hash>] + [(<tag> value) + (\ <hash> hash value)]) + ([#Primitive ..primitive_hash] + [#Structure (analysis.composite_hash recur_hash)] + [#Reference reference.hash] + [#Control (..control_hash recur_hash)] + [#Extension (extension.hash recur_hash)]))))) + +(template: #export (!bind_top register thenP) + ($_ ..path/seq + (#..Bind register) + #..Pop + thenP)) + +(template: #export (!multi_pop nextP) + ($_ ..path/seq + #..Pop + #..Pop + nextP)) + +## TODO: There are sister patterns to the simple side checks for tuples. +## These correspond to the situation where tuple members are accessed +## and bound to variables, but those variables are never used, so they +## become POPs. +## After re-implementing unused-variable-elimination, must add those +## pattern-optimizations again, since a lot of BINDs will become POPs +## and thus will result in useless code being generated. +(template [<name> <side>] + [(template: #export (<name> idx nextP) + ($_ ..path/seq + (<side> idx) + #..Pop + nextP))] + + [simple_left_side ..side/left] + [simple_right_side ..side/right] + ) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/version.lux b/stdlib/source/library/lux/tool/compiler/language/lux/version.lux new file mode 100644 index 000000000..dd3676068 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/version.lux @@ -0,0 +1,9 @@ +(.module: + [library + [lux #*]] + [//// + [version (#+ Version)]]) + +(def: #export version + Version + 00,06,00) diff --git a/stdlib/source/library/lux/tool/compiler/meta.lux b/stdlib/source/library/lux/tool/compiler/meta.lux new file mode 100644 index 000000000..23cacb4aa --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta.lux @@ -0,0 +1,9 @@ +(.module: + [library + [lux #*]] + [// + [version (#+ Version)]]) + +(def: #export version + Version + 00,01,00) diff --git a/stdlib/source/library/lux/tool/compiler/meta/archive.lux b/stdlib/source/library/lux/tool/compiler/meta/archive.lux new file mode 100644 index 000000000..d04f1227f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/archive.lux @@ -0,0 +1,280 @@ +(.module: + [library + [lux (#- Module) + [abstract + ["." equivalence (#+ Equivalence)] + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["." function] + ["<>" parser + ["<b>" binary (#+ Parser)]]] + [data + [binary (#+ Binary)] + ["." product] + ["." name] + ["." text + ["%" format (#+ format)]] + [format + ["." binary (#+ Writer)]] + [collection + ["." list ("#\." functor fold)] + ["." dictionary (#+ Dictionary)] + ["." set] + ["." row (#+ Row)]]] + [math + [number + ["n" nat ("#\." equivalence)]]] + [type + abstract]]] + [/ + ["." artifact] + ["." signature (#+ Signature)] + ["." key (#+ Key)] + ["." descriptor (#+ Module Descriptor)] + ["." document (#+ Document)] + [/// + [version (#+ Version)]]]) + +(type: #export Output + (Row [artifact.ID Binary])) + +(exception: #export (unknown_document {module Module} + {known_modules (List Module)}) + (exception.report + ["Module" (%.text module)] + ["Known Modules" (exception.enumerate %.text known_modules)])) + +(exception: #export (cannot_replace_document {module Module} + {old (Document Any)} + {new (Document Any)}) + (exception.report + ["Module" (%.text module)] + ["Old key" (signature.description (document.signature old))] + ["New key" (signature.description (document.signature new))])) + +(exception: #export (module_has_already_been_reserved {module Module}) + (exception.report + ["Module" (%.text module)])) + +(exception: #export (module_must_be_reserved_before_it_can_be_added {module Module}) + (exception.report + ["Module" (%.text module)])) + +(exception: #export (module_is_only_reserved {module Module}) + (exception.report + ["Module" (%.text module)])) + +(type: #export ID + Nat) + +(def: #export runtime_module + Module + "") + +(abstract: #export Archive + {#next ID + #resolver (Dictionary Module [ID (Maybe [Descriptor (Document Any) Output])])} + + (def: next + (-> Archive ID) + (|>> :representation (get@ #next))) + + (def: #export empty + Archive + (:abstraction {#next 0 + #resolver (dictionary.new text.hash)})) + + (def: #export (id module archive) + (-> Module Archive (Try ID)) + (let [(^slots [#..resolver]) (:representation archive)] + (case (dictionary.get module resolver) + (#.Some [id _]) + (#try.Success id) + + #.None + (exception.throw ..unknown_document [module + (dictionary.keys resolver)])))) + + (def: #export (reserve module archive) + (-> Module Archive (Try [ID Archive])) + (let [(^slots [#..next #..resolver]) (:representation archive)] + (case (dictionary.get module resolver) + (#.Some _) + (exception.throw ..module_has_already_been_reserved [module]) + + #.None + (#try.Success [next + (|> archive + :representation + (update@ #..resolver (dictionary.put module [next #.None])) + (update@ #..next inc) + :abstraction)])))) + + (def: #export (add module [descriptor document output] archive) + (-> Module [Descriptor (Document Any) Output] Archive (Try Archive)) + (let [(^slots [#..resolver]) (:representation archive)] + (case (dictionary.get module resolver) + (#.Some [id #.None]) + (#try.Success (|> archive + :representation + (update@ #..resolver (dictionary.put module [id (#.Some [descriptor document output])])) + :abstraction)) + + (#.Some [id (#.Some [existing_descriptor existing_document existing_output])]) + (if (is? document existing_document) + ## TODO: Find out why this code allows for the same module to be added more than once. It looks fishy... + (#try.Success archive) + (exception.throw ..cannot_replace_document [module existing_document document])) + + #.None + (exception.throw ..module_must_be_reserved_before_it_can_be_added [module])))) + + (def: #export (find module archive) + (-> Module Archive (Try [Descriptor (Document Any) Output])) + (let [(^slots [#..resolver]) (:representation archive)] + (case (dictionary.get module resolver) + (#.Some [id (#.Some entry)]) + (#try.Success entry) + + (#.Some [id #.None]) + (exception.throw ..module_is_only_reserved [module]) + + #.None + (exception.throw ..unknown_document [module + (dictionary.keys resolver)])))) + + (def: #export (archived? archive module) + (-> Archive Module Bit) + (case (..find module archive) + (#try.Success _) + yes + + (#try.Failure _) + no)) + + (def: #export archived + (-> Archive (List Module)) + (|>> :representation + (get@ #resolver) + dictionary.entries + (list.all (function (_ [module [id descriptor+document]]) + (case descriptor+document + (#.Some _) (#.Some module) + #.None #.None))))) + + (def: #export (reserved? archive module) + (-> Archive Module Bit) + (let [(^slots [#..resolver]) (:representation archive)] + (case (dictionary.get module resolver) + (#.Some [id _]) + yes + + #.None + no))) + + (def: #export reserved + (-> Archive (List Module)) + (|>> :representation + (get@ #resolver) + dictionary.keys)) + + (def: #export reservations + (-> Archive (List [Module ID])) + (|>> :representation + (get@ #resolver) + dictionary.entries + (list\map (function (_ [module [id _]]) + [module id])))) + + (def: #export (merge additions archive) + (-> Archive Archive Archive) + (let [[+next +resolver] (:representation additions)] + (|> archive + :representation + (update@ #next (n.max +next)) + (update@ #resolver (function (_ resolver) + (list\fold (function (_ [module [id entry]] resolver) + (case entry + (#.Some _) + (dictionary.put module [id entry] resolver) + + #.None + resolver)) + resolver + (dictionary.entries +resolver)))) + :abstraction))) + + (type: Reservation [Module ID]) + (type: Frozen [Version ID (List Reservation)]) + + (def: reader + (Parser ..Frozen) + ($_ <>.and + <b>.nat + <b>.nat + (<b>.list (<>.and <b>.text <b>.nat)))) + + (def: writer + (Writer ..Frozen) + ($_ binary.and + binary.nat + binary.nat + (binary.list (binary.and binary.text binary.nat)))) + + (def: #export (export version archive) + (-> Version Archive Binary) + (let [(^slots [#..next #..resolver]) (:representation archive)] + (|> resolver + dictionary.entries + (list.all (function (_ [module [id descriptor+document]]) + (case descriptor+document + (#.Some _) (#.Some [module id]) + #.None #.None))) + [version next] + (binary.run ..writer)))) + + (exception: #export (version_mismatch {expected Version} {actual Version}) + (exception.report + ["Expected" (%.nat expected)] + ["Actual" (%.nat actual)])) + + (exception: #export corrupt_data) + + (def: (correct_modules? reservations) + (-> (List Reservation) Bit) + (n.= (list.size reservations) + (|> reservations + (list\map product.left) + (set.from_list text.hash) + set.size))) + + (def: (correct_ids? reservations) + (-> (List Reservation) Bit) + (n.= (list.size reservations) + (|> reservations + (list\map product.right) + (set.from_list n.hash) + set.size))) + + (def: (correct_reservations? reservations) + (-> (List Reservation) Bit) + (and (correct_modules? reservations) + (correct_ids? reservations))) + + (def: #export (import expected binary) + (-> Version Binary (Try Archive)) + (do try.monad + [[actual next reservations] (<b>.run ..reader binary) + _ (exception.assert ..version_mismatch [expected actual] + (n\= expected actual)) + _ (exception.assert ..corrupt_data [] + (correct_reservations? reservations))] + (wrap (:abstraction + {#next next + #resolver (list\fold (function (_ [module id] archive) + (dictionary.put module [id #.None] archive)) + (get@ #resolver (:representation ..empty)) + reservations)})))) + ) diff --git a/stdlib/source/library/lux/tool/compiler/meta/archive/artifact.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/artifact.lux new file mode 100644 index 000000000..33e09e51a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/archive/artifact.lux @@ -0,0 +1,155 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." exception (#+ exception:)] + ["<>" parser + ["<b>" binary (#+ Parser)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list] + ["." row (#+ Row) ("#\." functor fold)] + ["." dictionary (#+ Dictionary)]] + [format + ["." binary (#+ Writer)]]] + [type + abstract]]]) + +(type: #export ID + Nat) + +(type: #export Category + #Anonymous + (#Definition Text) + (#Analyser Text) + (#Synthesizer Text) + (#Generator Text) + (#Directive Text)) + +(type: #export Artifact + {#id ID + #category Category}) + +(abstract: #export Registry + {#artifacts (Row Artifact) + #resolver (Dictionary Text ID)} + + (def: #export empty + Registry + (:abstraction {#artifacts row.empty + #resolver (dictionary.new text.hash)})) + + (def: #export artifacts + (-> Registry (Row Artifact)) + (|>> :representation (get@ #artifacts))) + + (def: next + (-> Registry ID) + (|>> ..artifacts row.size)) + + (def: #export (resource registry) + (-> Registry [ID Registry]) + (let [id (..next registry)] + [id + (|> registry + :representation + (update@ #artifacts (row.add {#id id + #category #Anonymous})) + :abstraction)])) + + (template [<tag> <create> <fetch>] + [(def: #export (<create> name registry) + (-> Text Registry [ID Registry]) + (let [id (..next registry)] + [id + (|> registry + :representation + (update@ #artifacts (row.add {#id id + #category (<tag> name)})) + (update@ #resolver (dictionary.put name id)) + :abstraction)])) + + (def: #export (<fetch> registry) + (-> Registry (List Text)) + (|> registry + :representation + (get@ #artifacts) + row.to_list + (list.all (|>> (get@ #category) + (case> (<tag> name) (#.Some name) + _ #.None)))))] + + [#Definition definition definitions] + [#Analyser analyser analysers] + [#Synthesizer synthesizer synthesizers] + [#Generator generator generators] + [#Directive directive directives] + ) + + (def: #export (remember name registry) + (-> Text Registry (Maybe ID)) + (|> (:representation registry) + (get@ #resolver) + (dictionary.get name))) + + (def: #export writer + (Writer Registry) + (let [category (: (Writer Category) + (function (_ value) + (case value + (^template [<nat> <tag> <writer>] + [(<tag> value) ((binary.and binary.nat <writer>) [<nat> value])]) + ([0 #Anonymous binary.any] + [1 #Definition binary.text] + [2 #Analyser binary.text] + [3 #Synthesizer binary.text] + [4 #Generator binary.text] + [5 #Directive binary.text])))) + artifacts (: (Writer (Row Category)) + (binary.row/64 category))] + (|>> :representation + (get@ #artifacts) + (row\map (get@ #category)) + artifacts))) + + (exception: #export (invalid_category {tag Nat}) + (exception.report + ["Tag" (%.nat tag)])) + + (def: #export parser + (Parser Registry) + (let [category (: (Parser Category) + (do {! <>.monad} + [tag <b>.nat] + (case tag + 0 (\ ! map (|>> #Anonymous) <b>.any) + 1 (\ ! map (|>> #Definition) <b>.text) + 2 (\ ! map (|>> #Analyser) <b>.text) + 3 (\ ! map (|>> #Synthesizer) <b>.text) + 4 (\ ! map (|>> #Generator) <b>.text) + 5 (\ ! map (|>> #Directive) <b>.text) + _ (<>.fail (exception.construct ..invalid_category [tag])))))] + (|> (<b>.row/64 category) + (\ <>.monad map (row\fold (function (_ artifact registry) + (product.right + (case artifact + #Anonymous + (..resource registry) + + (^template [<tag> <create>] + [(<tag> name) + (<create> name registry)]) + ([#Definition ..definition] + [#Analyser ..analyser] + [#Synthesizer ..synthesizer] + [#Generator ..generator] + [#Directive ..directive]) + ))) + ..empty))))) + ) diff --git a/stdlib/source/library/lux/tool/compiler/meta/archive/descriptor.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/descriptor.lux new file mode 100644 index 000000000..2c602ac89 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/archive/descriptor.lux @@ -0,0 +1,49 @@ +(.module: + [library + [lux (#- Module) + [control + ["<>" parser + ["<b>" binary (#+ Parser)]]] + [data + ["." text] + [collection + [set (#+ Set)]] + [format + ["." binary (#+ Writer)]]] + [world + [file (#+ Path)]]]] + [// + ["." artifact (#+ Registry)]]) + +(type: #export Module + Text) + +(type: #export Descriptor + {#name Module + #file Path + #hash Nat + #state Module_State + #references (Set Module) + #registry Registry}) + +(def: #export writer + (Writer Descriptor) + ($_ binary.and + binary.text + binary.text + binary.nat + binary.any + (binary.set binary.text) + artifact.writer + )) + +(def: #export parser + (Parser Descriptor) + ($_ <>.and + <b>.text + <b>.text + <b>.nat + (\ <>.monad wrap #.Cached) + (<b>.set text.hash <b>.text) + artifact.parser + )) diff --git a/stdlib/source/library/lux/tool/compiler/meta/archive/document.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/document.lux new file mode 100644 index 000000000..ea5ce1006 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/archive/document.lux @@ -0,0 +1,72 @@ +(.module: + [library + [lux (#- Module) + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser + [binary (#+ Parser)]]] + [data + [collection + ["." dictionary (#+ Dictionary)]] + [format + ["." binary (#+ Writer)]]] + [type (#+ :share) + abstract]]] + [// + ["." signature (#+ Signature)] + ["." key (#+ Key)] + [descriptor (#+ Module)]]) + +(exception: #export (invalid-signature {expected Signature} {actual Signature}) + (exception.report + ["Expected" (signature.description expected)] + ["Actual" (signature.description actual)])) + +(abstract: #export (Document d) + {#signature Signature + #content d} + + (def: #export (read key document) + (All [d] (-> (Key d) (Document Any) (Try d))) + (let [[document//signature document//content] (:representation document)] + (if (\ signature.equivalence = + (key.signature key) + document//signature) + (#try.Success (:share [e] + (Key e) + key + + e + (:assume document//content))) + (exception.throw ..invalid-signature [(key.signature key) + document//signature])))) + + (def: #export (write key content) + (All [d] (-> (Key d) d (Document d))) + (:abstraction {#signature (key.signature key) + #content content})) + + (def: #export (check key document) + (All [d] (-> (Key d) (Document Any) (Try (Document d)))) + (do try.monad + [_ (..read key document)] + (wrap (:assume document)))) + + (def: #export signature + (-> (Document Any) Signature) + (|>> :representation (get@ #signature))) + + (def: #export (writer content) + (All [d] (-> (Writer d) (Writer (Document d)))) + (let [writer (binary.and signature.writer + content)] + (|>> :representation writer))) + + (def: #export parser + (All [d] (-> (Parser d) (Parser (Document d)))) + (|>> (<>.and signature.parser) + (\ <>.monad map (|>> :abstraction)))) + ) diff --git a/stdlib/source/library/lux/tool/compiler/meta/archive/key.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/key.lux new file mode 100644 index 000000000..ec6439aa7 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/archive/key.lux @@ -0,0 +1,19 @@ +(.module: + [library + [lux #* + [type + abstract]]] + [// + [signature (#+ Signature)]]) + +(abstract: #export (Key k) + Signature + + (def: #export signature + (-> (Key Any) Signature) + (|>> :representation)) + + (def: #export (key signature sample) + (All [d] (-> Signature d (Key d))) + (:abstraction signature)) + ) diff --git a/stdlib/source/library/lux/tool/compiler/meta/archive/signature.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/signature.lux new file mode 100644 index 000000000..e39bb2144 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/archive/signature.lux @@ -0,0 +1,42 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [control + ["<>" parser + ["<b>" binary (#+ Parser)]]] + [data + ["." product] + ["." name] + ["." text + ["%" format (#+ format)]] + [format + ["." binary (#+ Writer)]]] + [math + [number + ["." nat]]]]] + [//// + [version (#+ Version)]]) + +(type: #export Signature + {#name Name + #version Version}) + +(def: #export equivalence + (Equivalence Signature) + (product.equivalence name.equivalence nat.equivalence)) + +(def: #export (description signature) + (-> Signature Text) + (format (%.name (get@ #name signature)) " " (%.nat (get@ #version signature)))) + +(def: #export writer + (Writer Signature) + (binary.and (binary.and binary.text binary.text) + binary.nat)) + +(def: #export parser + (Parser Signature) + (<>.and (<>.and <b>.text <b>.text) + <b>.nat)) diff --git a/stdlib/source/library/lux/tool/compiler/meta/cache/dependency.lux b/stdlib/source/library/lux/tool/compiler/meta/cache/dependency.lux new file mode 100644 index 000000000..3ba514b5f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/cache/dependency.lux @@ -0,0 +1,97 @@ +(.module: + [library + [lux (#- Module) + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." state] + ["." function + ["." memo (#+ Memo)]]] + [data + ["." maybe ("#\." functor)] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." dictionary (#+ Dictionary)] + ["." set (#+ Set)]]]]] + [/// + ["." archive (#+ Output Archive) + [key (#+ Key)] + ["." descriptor (#+ Module Descriptor)] + ["." document (#+ Document)]]]) + +(type: Ancestry + (Set Module)) + +(def: fresh + Ancestry + (set.new text.hash)) + +(type: #export Graph + (Dictionary Module Ancestry)) + +(def: empty + Graph + (dictionary.new text.hash)) + +(def: #export modules + (-> Graph (List Module)) + dictionary.keys) + +(type: Dependency + {#module Module + #imports Ancestry}) + +(def: #export graph + (-> (List Dependency) Graph) + (list\fold (function (_ [module imports] graph) + (dictionary.put module imports graph)) + ..empty)) + +(def: (ancestry archive) + (-> Archive Graph) + (let [memo (: (Memo Module Ancestry) + (function (_ recur module) + (do {! state.monad} + [#let [parents (case (archive.find module archive) + (#try.Success [descriptor document]) + (get@ #descriptor.references descriptor) + + (#try.Failure error) + ..fresh)] + ancestors (monad.map ! recur (set.to_list parents))] + (wrap (list\fold set.union parents ancestors))))) + ancestry (memo.open memo)] + (list\fold (function (_ module memory) + (if (dictionary.key? memory module) + memory + (let [[memory _] (ancestry [memory module])] + memory))) + ..empty + (archive.archived archive)))) + +(def: (dependency? ancestry target source) + (-> Graph Module Module Bit) + (let [target_ancestry (|> ancestry + (dictionary.get target) + (maybe.default ..fresh))] + (set.member? target_ancestry source))) + +(type: #export Order + (List [Module [archive.ID [Descriptor (Document .Module) Output]]])) + +(def: #export (load_order key archive) + (-> (Key .Module) Archive (Try Order)) + (let [ancestry (..ancestry archive)] + (|> ancestry + dictionary.keys + (list.sort (..dependency? ancestry)) + (monad.map try.monad + (function (_ module) + (do try.monad + [module_id (archive.id module archive) + [descriptor document output] (archive.find module archive) + document (document.check key document)] + (wrap [module [module_id [descriptor document output]]]))))))) diff --git a/stdlib/source/library/lux/tool/compiler/meta/io.lux b/stdlib/source/library/lux/tool/compiler/meta/io.lux new file mode 100644 index 000000000..fe11727b7 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/io.lux @@ -0,0 +1,20 @@ +(.module: + [library + [lux (#- Code) + [data + ["." text]] + [world + [file (#+ Path System)]]]]) + +(type: #export Context + Path) + +(type: #export Code + Text) + +(def: #export (sanitize system) + (All [m] (-> (System m) Text Text)) + (text.replace_all "/" (\ system separator))) + +(def: #export lux_context + "lux") diff --git a/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux new file mode 100644 index 000000000..b5ed4b84b --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux @@ -0,0 +1,450 @@ +(.module: + [library + [lux (#- Module) + [target (#+ Target)] + [abstract + [predicate (#+ Predicate)] + ["." monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + [concurrency + ["." promise (#+ Promise) ("#\." monad)]] + ["<>" parser + ["<.>" binary (#+ Parser)]]] + [data + [binary (#+ Binary)] + ["." product] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." dictionary (#+ Dictionary)] + ["." row (#+ Row)] + ["." set]]] + [math + [number + ["n" nat]]] + [world + ["." file]]]] + [program + [compositor + [import (#+ Import)] + ["." static (#+ Static)]]] + ["." // (#+ Context) + ["#." context] + ["/#" // + ["." archive (#+ Output Archive) + ["." artifact (#+ Artifact)] + ["." descriptor (#+ Module Descriptor)] + ["." document (#+ Document)]] + [cache + ["." dependency]] + ["/#" // (#+ Input) + [language + ["$" lux + ["." version] + ["." analysis] + ["." synthesis] + ["." generation] + ["." directive] + ["#/." program]]]]]]) + +(exception: #export (cannot_prepare {archive file.Path} + {module_id archive.ID} + {error Text}) + (exception.report + ["Archive" archive] + ["Module ID" (%.nat module_id)] + ["Error" error])) + +(def: (archive fs static) + (All [!] (-> (file.System !) Static file.Path)) + (format (get@ #static.target static) + (\ fs separator) + (get@ #static.host static))) + +(def: (unversioned_lux_archive fs static) + (All [!] (-> (file.System !) Static file.Path)) + (format (..archive fs static) + (\ fs separator) + //.lux_context)) + +(def: (versioned_lux_archive fs static) + (All [!] (-> (file.System !) Static file.Path)) + (format (..unversioned_lux_archive fs static) + (\ fs separator) + (%.nat version.version))) + +(def: (module fs static module_id) + (All [!] (-> (file.System !) Static archive.ID file.Path)) + (format (..versioned_lux_archive fs static) + (\ fs separator) + (%.nat module_id))) + +(def: #export (artifact fs static module_id artifact_id) + (All [!] (-> (file.System !) Static archive.ID artifact.ID file.Path)) + (format (..module fs static module_id) + (\ fs separator) + (%.nat artifact_id) + (get@ #static.artifact_extension static))) + +(def: (ensure_directory fs path) + (-> (file.System Promise) file.Path (Promise (Try Any))) + (do promise.monad + [? (\ fs directory? path)] + (if ? + (wrap (#try.Success [])) + (\ fs make_directory path)))) + +(def: #export (prepare fs static module_id) + (-> (file.System Promise) Static archive.ID (Promise (Try Any))) + (do {! promise.monad} + [#let [module (..module fs static module_id)] + module_exists? (\ fs directory? module)] + (if module_exists? + (wrap (#try.Success [])) + (do (try.with !) + [_ (ensure_directory fs (..unversioned_lux_archive fs static)) + _ (ensure_directory fs (..versioned_lux_archive fs static))] + (|> module + (\ fs make_directory) + (\ ! map (|>> (case> (#try.Success output) + (#try.Success []) + + (#try.Failure error) + (exception.throw ..cannot_prepare [(..archive fs static) + module_id + error]))))))))) + +(def: #export (write fs static module_id artifact_id content) + (-> (file.System Promise) Static archive.ID artifact.ID Binary (Promise (Try Any))) + (\ fs write content (..artifact fs static module_id artifact_id))) + +(def: #export (enable fs static) + (-> (file.System Promise) Static (Promise (Try Any))) + (do (try.with promise.monad) + [_ (..ensure_directory fs (get@ #static.target static))] + (..ensure_directory fs (..archive fs static)))) + +(def: (general_descriptor fs static) + (-> (file.System Promise) Static file.Path) + (format (..archive fs static) + (\ fs separator) + "general_descriptor")) + +(def: #export (freeze fs static archive) + (-> (file.System Promise) Static Archive (Promise (Try Any))) + (\ fs write (archive.export ///.version archive) (..general_descriptor fs static))) + +(def: module_descriptor_file + "module_descriptor") + +(def: (module_descriptor fs static module_id) + (-> (file.System Promise) Static archive.ID file.Path) + (format (..module fs static module_id) + (\ fs separator) + ..module_descriptor_file)) + +(def: #export (cache fs static module_id content) + (-> (file.System Promise) Static archive.ID Binary (Promise (Try Any))) + (\ fs write content (..module_descriptor fs static module_id))) + +(def: (read_module_descriptor fs static module_id) + (-> (file.System Promise) Static archive.ID (Promise (Try Binary))) + (\ fs read (..module_descriptor fs static module_id))) + +(def: parser + (Parser [Descriptor (Document .Module)]) + (<>.and descriptor.parser + (document.parser $.parser))) + +(def: (fresh_analysis_state host) + (-> Target .Lux) + (analysis.state (analysis.info version.version host))) + +(def: (analysis_state host archive) + (-> Target Archive (Try .Lux)) + (do {! try.monad} + [modules (: (Try (List [Module .Module])) + (monad.map ! (function (_ module) + (do ! + [[descriptor document output] (archive.find module archive) + content (document.read $.key document)] + (wrap [module content]))) + (archive.archived archive)))] + (wrap (set@ #.modules modules (fresh_analysis_state host))))) + +(def: (cached_artifacts fs static module_id) + (-> (file.System Promise) Static archive.ID (Promise (Try (Dictionary Text Binary)))) + (let [! (try.with promise.monad)] + (|> (..module fs static module_id) + (\ fs directory_files) + (\ ! map (|>> (list\map (function (_ file) + [(file.name fs file) file])) + (list.filter (|>> product.left (text\= ..module_descriptor_file) not)) + (monad.map ! (function (_ [name path]) + (|> path + (\ fs read) + (\ ! map (|>> [name]))))) + (\ ! map (dictionary.from_list text.hash)))) + (\ ! join)))) + +(type: Definitions (Dictionary Text Any)) +(type: Analysers (Dictionary Text analysis.Handler)) +(type: Synthesizers (Dictionary Text synthesis.Handler)) +(type: Generators (Dictionary Text generation.Handler)) +(type: Directives (Dictionary Text directive.Handler)) + +(type: Bundles + [Analysers + Synthesizers + Generators + Directives]) + +(def: empty_bundles + Bundles + [(dictionary.new text.hash) + (dictionary.new text.hash) + (dictionary.new text.hash) + (dictionary.new text.hash)]) + +(def: (loaded_document extension host module_id expected actual document) + (All [expression directive] + (-> Text (generation.Host expression directive) archive.ID (Row Artifact) (Dictionary Text Binary) (Document .Module) + (Try [(Document .Module) Bundles]))) + (do {! try.monad} + [[definitions bundles] (: (Try [Definitions Bundles]) + (loop [input (row.to_list expected) + definitions (: Definitions + (dictionary.new text.hash)) + bundles ..empty_bundles] + (let [[analysers synthesizers generators directives] bundles] + (case input + (#.Cons [[artifact_id artifact_category] input']) + (case (do ! + [data (try.from_maybe (dictionary.get (format (%.nat artifact_id) extension) actual)) + #let [context [module_id artifact_id] + directive (\ host ingest context data)]] + (case artifact_category + #artifact.Anonymous + (do ! + [_ (\ host re_learn context directive)] + (wrap [definitions + [analysers + synthesizers + generators + directives]])) + + (#artifact.Definition name) + (if (text\= $/program.name name) + (wrap [definitions + [analysers + synthesizers + generators + directives]]) + (do ! + [value (\ host re_load context directive)] + (wrap [(dictionary.put name value definitions) + [analysers + synthesizers + generators + directives]]))) + + (#artifact.Analyser extension) + (do ! + [value (\ host re_load context directive)] + (wrap [definitions + [(dictionary.put extension (:as analysis.Handler value) analysers) + synthesizers + generators + directives]])) + + (#artifact.Synthesizer extension) + (do ! + [value (\ host re_load context directive)] + (wrap [definitions + [analysers + (dictionary.put extension (:as synthesis.Handler value) synthesizers) + generators + directives]])) + + (#artifact.Generator extension) + (do ! + [value (\ host re_load context directive)] + (wrap [definitions + [analysers + synthesizers + (dictionary.put extension (:as generation.Handler value) generators) + directives]])) + + (#artifact.Directive extension) + (do ! + [value (\ host re_load context directive)] + (wrap [definitions + [analysers + synthesizers + generators + (dictionary.put extension (:as directive.Handler value) directives)]])))) + (#try.Success [definitions' bundles']) + (recur input' definitions' bundles') + + failure + failure) + + #.None + (#try.Success [definitions bundles]))))) + content (document.read $.key document) + definitions (monad.map ! (function (_ [def_name def_global]) + (case def_global + (#.Alias alias) + (wrap [def_name (#.Alias alias)]) + + (#.Definition [exported? type annotations _]) + (do ! + [value (try.from_maybe (dictionary.get def_name definitions))] + (wrap [def_name (#.Definition [exported? type annotations value])])))) + (get@ #.definitions content))] + (wrap [(document.write $.key (set@ #.definitions definitions content)) + bundles]))) + +(def: (load_definitions fs static module_id host_environment [descriptor document output]) + (All [expression directive] + (-> (file.System Promise) Static archive.ID (generation.Host expression directive) + [Descriptor (Document .Module) Output] + (Promise (Try [[Descriptor (Document .Module) Output] + Bundles])))) + (do (try.with promise.monad) + [actual (cached_artifacts fs static module_id) + #let [expected (|> descriptor (get@ #descriptor.registry) artifact.artifacts)] + [document bundles] (promise\wrap (loaded_document (get@ #static.artifact_extension static) host_environment module_id expected actual document))] + (wrap [[descriptor document output] bundles]))) + +(def: (purge! fs static [module_name module_id]) + (-> (file.System Promise) Static [Module archive.ID] (Promise (Try Any))) + (do {! (try.with promise.monad)} + [#let [cache (..module fs static module_id)] + _ (|> cache + (\ fs directory_files) + (\ ! map (monad.map ! (\ fs delete))) + (\ ! join))] + (\ fs delete cache))) + +(def: (valid_cache? expected actual) + (-> Descriptor Input Bit) + (and (text\= (get@ #descriptor.name expected) + (get@ #////.module actual)) + (text\= (get@ #descriptor.file expected) + (get@ #////.file actual)) + (n.= (get@ #descriptor.hash expected) + (get@ #////.hash actual)))) + +(type: Purge + (Dictionary Module archive.ID)) + +(def: initial_purge + (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module) Output]]]]) + Purge) + (|>> (list.all (function (_ [valid_cache? [module_name [module_id _]]]) + (if valid_cache? + #.None + (#.Some [module_name module_id])))) + (dictionary.from_list text.hash))) + +(def: (full_purge caches load_order) + (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module) Output]]]]) + dependency.Order + Purge) + (list\fold (function (_ [module_name [module_id [descriptor document output]]] purge) + (let [purged? (: (Predicate Module) + (dictionary.key? purge))] + (if (purged? module_name) + purge + (if (|> descriptor + (get@ #descriptor.references) + set.to_list + (list.any? purged?)) + (dictionary.put module_name module_id purge) + purge)))) + (..initial_purge caches) + load_order)) + +(def: pseudo_module + Text + "(Lux Caching System)") + +(def: (load_every_reserved_module host_environment fs static import contexts archive) + (All [expression directive] + (-> (generation.Host expression directive) (file.System Promise) Static Import (List Context) Archive + (Promise (Try [Archive .Lux Bundles])))) + (do {! (try.with promise.monad)} + [pre_loaded_caches (|> archive + archive.reservations + (monad.map ! (function (_ [module_name module_id]) + (do ! + [data (..read_module_descriptor fs static module_id) + [descriptor document] (promise\wrap (<binary>.run ..parser data))] + (if (text\= archive.runtime_module module_name) + (wrap [true + [module_name [module_id [descriptor document (: Output row.empty)]]]]) + (do ! + [input (//context.read fs ..pseudo_module import contexts (get@ #static.host_module_extension static) module_name)] + (wrap [(..valid_cache? descriptor input) + [module_name [module_id [descriptor document (: Output row.empty)]]]]))))))) + load_order (|> pre_loaded_caches + (list\map product.right) + (monad.fold try.monad + (function (_ [module [module_id descriptor,document,output]] archive) + (archive.add module descriptor,document,output archive)) + archive) + (\ try.monad map (dependency.load_order $.key)) + (\ try.monad join) + promise\wrap) + #let [purge (..full_purge pre_loaded_caches load_order)] + _ (|> purge + dictionary.entries + (monad.map ! (..purge! fs static))) + loaded_caches (|> load_order + (list.filter (function (_ [module_name [module_id [descriptor document output]]]) + (not (dictionary.key? purge module_name)))) + (monad.map ! (function (_ [module_name [module_id descriptor,document,output]]) + (do ! + [[descriptor,document,output bundles] (..load_definitions fs static module_id host_environment descriptor,document,output)] + (wrap [[module_name descriptor,document,output] + bundles])))))] + (promise\wrap + (do {! try.monad} + [archive (monad.fold ! + (function (_ [[module descriptor,document] _bundle] archive) + (archive.add module descriptor,document archive)) + archive + loaded_caches) + analysis_state (..analysis_state (get@ #static.host static) archive)] + (wrap [archive + analysis_state + (list\fold (function (_ [_ [+analysers +synthesizers +generators +directives]] + [analysers synthesizers generators directives]) + [(dictionary.merge +analysers analysers) + (dictionary.merge +synthesizers synthesizers) + (dictionary.merge +generators generators) + (dictionary.merge +directives directives)]) + ..empty_bundles + loaded_caches)]))))) + +(def: #export (thaw host_environment fs static import contexts) + (All [expression directive] + (-> (generation.Host expression directive) (file.System Promise) Static Import (List Context) + (Promise (Try [Archive .Lux Bundles])))) + (do promise.monad + [binary (\ fs read (..general_descriptor fs static))] + (case binary + (#try.Success binary) + (do (try.with promise.monad) + [archive (promise\wrap (archive.import ///.version binary))] + (..load_every_reserved_module host_environment fs static import contexts archive)) + + (#try.Failure error) + (wrap (#try.Success [archive.empty + (fresh_analysis_state (get@ #static.host static)) + ..empty_bundles]))))) diff --git a/stdlib/source/library/lux/tool/compiler/meta/io/context.lux b/stdlib/source/library/lux/tool/compiler/meta/io/context.lux new file mode 100644 index 000000000..6e619d93d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/io/context.lux @@ -0,0 +1,170 @@ +(.module: + [library + [lux (#- Module Code) + ["@" target] + [abstract + [predicate (#+ Predicate)] + ["." monad (#+ Monad do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + [concurrency + ["." promise (#+ Promise) ("#\." monad)]]] + [data + [binary (#+ Binary)] + ["." text ("#\." hash) + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." dictionary (#+ Dictionary)]]] + [world + ["." file]]]] + [program + [compositor + [import (#+ Import)]]] + ["." // (#+ Context Code) + ["/#" // #_ + [archive + [descriptor (#+ Module)]] + ["/#" // (#+ Input)]]]) + +(exception: #export (cannot_find_module {importer Module} {module Module}) + (exception.report + ["Module" (%.text module)] + ["Importer" (%.text importer)])) + +(exception: #export (cannot_read_module {module Module}) + (exception.report + ["Module" (%.text module)])) + +(type: #export Extension + Text) + +(def: lux_extension + Extension + ".lux") + +(def: #export (path fs context module) + (All [m] (-> (file.System m) Context Module file.Path)) + (|> module + (//.sanitize fs) + (format context (\ fs separator)))) + +(def: (find_source_file fs importer contexts module extension) + (-> (file.System Promise) Module (List Context) Module Extension + (Promise (Try file.Path))) + (case contexts + #.Nil + (promise\wrap (exception.throw ..cannot_find_module [importer module])) + + (#.Cons context contexts') + (let [path (format (..path fs context module) extension)] + (do promise.monad + [? (\ fs file? path)] + (if ? + (wrap (#try.Success path)) + (find_source_file fs importer contexts' module extension)))))) + +(def: (full_host_extension partial_host_extension) + (-> Extension Extension) + (format partial_host_extension ..lux_extension)) + +(def: (find_local_source_file fs importer import contexts partial_host_extension module) + (-> (file.System Promise) Module Import (List Context) Extension Module + (Promise (Try [file.Path Binary]))) + ## Preference is explicitly being given to Lux files that have a host extension. + ## Normal Lux files (i.e. without a host extension) are then picked as fallback files. + (do {! promise.monad} + [outcome (..find_source_file fs importer contexts module (..full_host_extension partial_host_extension))] + (case outcome + (#try.Success path) + (|> path + (\ fs read) + (\ (try.with !) map (|>> [path]))) + + (#try.Failure _) + (do {! (try.with !)} + [path (..find_source_file fs importer contexts module ..lux_extension)] + (|> path + (\ fs read) + (\ ! map (|>> [path]))))))) + +(def: (find_library_source_file importer import partial_host_extension module) + (-> Module Import Extension Module (Try [file.Path Binary])) + (let [path (format module (..full_host_extension partial_host_extension))] + (case (dictionary.get path import) + (#.Some data) + (#try.Success [path data]) + + #.None + (let [path (format module ..lux_extension)] + (case (dictionary.get path import) + (#.Some data) + (#try.Success [path data]) + + #.None + (exception.throw ..cannot_find_module [importer module])))))) + +(def: (find_any_source_file fs importer import contexts partial_host_extension module) + (-> (file.System Promise) Module Import (List Context) Extension Module + (Promise (Try [file.Path Binary]))) + ## Preference is explicitly being given to Lux files that have a host extension. + ## Normal Lux files (i.e. without a host extension) are then picked as fallback files. + (do {! promise.monad} + [outcome (find_local_source_file fs importer import contexts partial_host_extension module)] + (case outcome + (#try.Success [path data]) + (wrap outcome) + + (#try.Failure _) + (wrap (..find_library_source_file importer import partial_host_extension module))))) + +(def: #export (read fs importer import contexts partial_host_extension module) + (-> (file.System Promise) Module Import (List Context) Extension Module + (Promise (Try Input))) + (do (try.with promise.monad) + [[path binary] (..find_any_source_file fs importer import contexts partial_host_extension module)] + (case (\ utf8.codec decode binary) + (#try.Success code) + (wrap {#////.module module + #////.file path + #////.hash (text\hash code) + #////.code code}) + + (#try.Failure _) + (promise\wrap (exception.throw ..cannot_read_module [module]))))) + +(type: #export Enumeration + (Dictionary file.Path Binary)) + +(def: (enumerate_context fs directory enumeration) + (-> (file.System Promise) Context Enumeration (Promise (Try Enumeration))) + (do {! (try.with promise.monad)} + [enumeration (|> directory + (\ fs directory_files) + (\ ! map (monad.fold ! (function (_ file enumeration) + (if (text.ends_with? ..lux_extension file) + (do ! + [source_code (\ fs read file)] + (promise\wrap + (dictionary.try_put (file.name fs file) source_code enumeration))) + (wrap enumeration))) + enumeration)) + (\ ! join))] + (|> directory + (\ fs sub_directories) + (\ ! map (monad.fold ! (enumerate_context fs) enumeration)) + (\ ! join)))) + +(def: Action + (type (All [a] (Promise (Try a))))) + +(def: #export (enumerate fs contexts) + (-> (file.System Promise) (List Context) (Action Enumeration)) + (monad.fold (: (Monad Action) + (try.with promise.monad)) + (..enumerate_context fs) + (: Enumeration + (dictionary.new text.hash)) + contexts)) diff --git a/stdlib/source/library/lux/tool/compiler/meta/packager.lux b/stdlib/source/library/lux/tool/compiler/meta/packager.lux new file mode 100644 index 000000000..621045e33 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/packager.lux @@ -0,0 +1,43 @@ +(.module: + [library + [lux #* + [abstract + [monad (#+ Monad)]] + [control + [try (#+ Try)]] + [data + [binary (#+ Binary)] + [collection + ["." row] + ["." list ("#\." functor)]]] + [world + ["." file (#+ Path)]]]] + [program + [compositor + [static (#+ Static)]]] + [// + [cache + ["." dependency]] + ["." archive (#+ Archive) + ["." descriptor] + ["." artifact]] + [// + [language + [lux + [generation (#+ Context)]]]]]) + +(type: #export Packager + (-> Archive Context (Try Binary))) + +(type: #export Order + (List [archive.ID (List artifact.ID)])) + +(def: #export order + (-> dependency.Order Order) + (list\map (function (_ [module [module_id [descriptor document]]]) + (|> descriptor + (get@ #descriptor.registry) + artifact.artifacts + row.to_list + (list\map (|>> (get@ #artifact.id))) + [module_id])))) diff --git a/stdlib/source/library/lux/tool/compiler/meta/packager/jvm.lux b/stdlib/source/library/lux/tool/compiler/meta/packager/jvm.lux new file mode 100644 index 000000000..f5366ab8e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/packager/jvm.lux @@ -0,0 +1,145 @@ +(.module: + [library + [lux (#- Module Definition) + [type (#+ :share)] + ["." ffi (#+ import: do_to)] + [abstract + ["." monad (#+ Monad do)]] + [control + ["." try (#+ Try)] + [concurrency + ["." promise (#+ Promise)]]] + [data + ["." binary (#+ Binary)] + ["." text + ["%" format (#+ format)]] + [collection + ["." row (#+ Row) ("#\." fold)] + ["." list ("#\." functor fold)]]] + [math + [number + ["n" nat]]] + [target + [jvm + [encoding + ["." name]]]]]] + [program + [compositor + ["." static (#+ Static)]]] + ["." // (#+ Packager) + [// + ["." archive (#+ Output) + ["." descriptor (#+ Module)] + ["." artifact]] + [cache + ["." dependency]] + ["." io #_ + ["#" archive]] + [// + [language + ["$" lux + [generation (#+ Context)] + [phase + [generation + [jvm + ["." runtime (#+ Definition)]]]]]]]]]) + +(import: java/lang/Object) + +(import: java/lang/String) + +(import: java/util/jar/Attributes + ["#::." + (put [java/lang/Object java/lang/Object] #? java/lang/Object)]) + +(import: java/util/jar/Attributes$Name + ["#::." + (#static MAIN_CLASS java/util/jar/Attributes$Name) + (#static MANIFEST_VERSION java/util/jar/Attributes$Name)]) + +(import: java/util/jar/Manifest + ["#::." + (new []) + (getMainAttributes [] java/util/jar/Attributes)]) + +(import: java/io/Flushable + ["#::." + (flush [] void)]) + +(import: java/io/Closeable + ["#::." + (close [] void)]) + +(import: java/io/OutputStream) + +(import: java/io/ByteArrayOutputStream + ["#::." + (new [int]) + (toByteArray [] [byte])]) + +(import: java/util/zip/ZipEntry) + +(import: java/util/zip/ZipOutputStream + ["#::." + (write [[byte] int int] void) + (closeEntry [] void)]) + +(import: java/util/jar/JarEntry + ["#::." + (new [java/lang/String])]) + +(import: java/util/jar/JarOutputStream + ["#::." + (new [java/io/OutputStream java/util/jar/Manifest]) + (putNextEntry [java/util/zip/ZipEntry] void)]) + +(def: byte 1) +## https://en.wikipedia.org/wiki/Kibibyte +(def: kibi_byte (n.* 1,024 byte)) +## https://en.wikipedia.org/wiki/Mebibyte +(def: mebi_byte (n.* 1,024 kibi_byte)) + +(def: manifest_version "1.0") + +(def: (manifest program) + (-> Context java/util/jar/Manifest) + (let [manifest (java/util/jar/Manifest::new)] + (exec (do_to (java/util/jar/Manifest::getMainAttributes manifest) + (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MAIN_CLASS) (|> program runtime.class_name name.internal name.external)) + (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MANIFEST_VERSION) ..manifest_version)) + manifest))) + +(def: (write_class static module artifact content sink) + (-> Static archive.ID artifact.ID Binary java/util/jar/JarOutputStream + java/util/jar/JarOutputStream) + (let [class_path (format (runtime.class_name [module artifact]) + (get@ #static.artifact_extension static))] + (do_to sink + (java/util/jar/JarOutputStream::putNextEntry (java/util/jar/JarEntry::new class_path)) + (java/util/zip/ZipOutputStream::write content +0 (.int (binary.size content))) + (java/io/Flushable::flush) + (java/util/zip/ZipOutputStream::closeEntry)))) + +(def: (write_module static [module output] sink) + (-> Static [archive.ID Output] java/util/jar/JarOutputStream + java/util/jar/JarOutputStream) + (row\fold (function (_ [artifact content] sink) + (..write_class static module artifact content sink)) + sink + output)) + +(def: #export (package static) + (-> Static Packager) + (function (_ archive program) + (do {! try.monad} + [order (dependency.load_order $.key archive) + #let [buffer (java/io/ByteArrayOutputStream::new (.int ..mebi_byte)) + sink (|> order + (list\map (function (_ [module [module_id [descriptor document output]]]) + [module_id output])) + (list\fold (..write_module static) + (java/util/jar/JarOutputStream::new buffer (..manifest program)))) + _ (do_to sink + (java/io/Flushable::flush) + (java/io/Closeable::close))]] + (wrap (java/io/ByteArrayOutputStream::toByteArray buffer))))) diff --git a/stdlib/source/library/lux/tool/compiler/meta/packager/scheme.lux b/stdlib/source/library/lux/tool/compiler/meta/packager/scheme.lux new file mode 100644 index 000000000..bcd06b6fd --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/packager/scheme.lux @@ -0,0 +1,132 @@ +(.module: + [library + [lux (#- Module) + [type (#+ :share)] + [abstract + ["." monad (#+ Monad do)]] + [control + ["." try (#+ Try)]] + [data + [binary (#+ Binary)] + ["." product] + ["." text + ["%" format (#+ format)] + ["." encoding]] + [collection + ["." row] + ["." list ("#\." functor fold)] + ["." dictionary (#+ Dictionary)] + ["." set]] + [format + ["." tar] + ["." binary]]] + [target + ["_" scheme]] + [time + ["." instant (#+ Instant)]] + [world + ["." file]]]] + [program + [compositor + ["." static (#+ Static)]]] + ["." // (#+ Packager) + [// + ["." archive (#+ Output) + ["." descriptor (#+ Module Descriptor)] + ["." artifact] + ["." document (#+ Document)]] + [cache + ["." dependency]] + ["." io #_ + ["#" archive]] + [// + [language + ["$" lux + [generation (#+ Context)]]]]]]) + +## TODO: Delete ASAP +(type: (Action ! a) + (! (Try a))) + +(def: (then pre post) + (-> _.Expression _.Expression _.Expression) + (_.manual (format (_.code pre) + text.new_line + (_.code post)))) + +(def: bundle_module + (-> Output (Try _.Expression)) + (|>> row.to_list + (list\map product.right) + (monad.fold try.monad + (function (_ content so_far) + (|> content + (\ encoding.utf8 decode) + (\ try.monad map + (|>> :assume + (:share [directive] + directive + so_far + + directive) + (..then so_far))))) + (: _.Expression (_.manual ""))))) + +(def: module_file + (-> archive.ID file.Path) + (|>> %.nat (text.suffix ".scm"))) + +(def: mode + tar.Mode + ($_ tar.and + tar.read_by_group + tar.read_by_owner + + tar.write_by_other + tar.write_by_group + tar.write_by_owner)) + +(def: owner + tar.Owner + {#tar.name tar.anonymous + #tar.id tar.no_id}) + +(def: ownership + {#tar.user ..owner + #tar.group ..owner}) + +(def: (write_module now mapping [module [module_id [descriptor document output]]]) + (-> Instant (Dictionary Module archive.ID) + [Module [archive.ID [Descriptor (Document .Module) Output]]] + (Try tar.Entry)) + (do {! try.monad} + [bundle (: (Try _.Expression) + (..bundle_module output)) + entry_content (: (Try tar.Content) + (|> descriptor + (get@ #descriptor.references) + set.to_list + (list.all (function (_ module) (dictionary.get module mapping))) + (list\map (|>> ..module_file _.string _.load-relative/1)) + (list\fold ..then bundle) + (: _.Expression) + _.code + (\ encoding.utf8 encode) + tar.content)) + module_file (tar.path (..module_file module_id))] + (wrap (#tar.Normal [module_file now ..mode ..ownership entry_content])))) + +(def: #export (package now) + (-> Instant Packager) + (function (package archive program) + (do {! try.monad} + [order (dependency.load_order $.key archive) + #let [mapping (|> order + (list\map (function (_ [module [module_id [descriptor document output]]]) + [module module_id])) + (dictionary.from_list text.hash) + (: (Dictionary Module archive.ID)))] + entries (monad.map ! (..write_module now mapping) order)] + (wrap (|> entries + row.from_list + (binary.run tar.writer)))))) diff --git a/stdlib/source/library/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/library/lux/tool/compiler/meta/packager/script.lux new file mode 100644 index 000000000..ac2b5758c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/packager/script.lux @@ -0,0 +1,76 @@ +(.module: + [library + [lux #* + [type (#+ :share)] + [abstract + ["." monad (#+ Monad do)]] + [control + ["." try (#+ Try)]] + [data + [binary (#+ Binary)] + ["." product] + [text + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." row] + ["." list ("#\." functor)]]]]] + [program + [compositor + ["." static (#+ Static)]]] + ["." // (#+ Packager) + [// + ["." archive (#+ Output) + ["." descriptor] + ["." artifact]] + [cache + ["." dependency]] + ["." io #_ + ["#" archive]] + [// + [language + ["$" lux + [generation (#+ Context)]]]]]]) + +## TODO: Delete ASAP +(type: (Action ! a) + (! (Try a))) + +(def: (write_module sequence [module output] so_far) + (All [directive] + (-> (-> directive directive directive) [archive.ID Output] directive + (Try directive))) + (|> output + row.to_list + (list\map product.right) + (monad.fold try.monad + (function (_ content so_far) + (|> content + (\ utf8.codec decode) + (\ try.monad map + (function (_ content) + (sequence so_far + (:share [directive] + directive + so_far + + directive + (:assume content))))))) + so_far))) + +(def: #export (package header to_code sequence scope) + (All [directive] + (-> directive + (-> directive Text) + (-> directive directive directive) + (-> directive directive) + Packager)) + (function (package archive program) + (do {! try.monad} + [order (dependency.load_order $.key archive)] + (|> order + (list\map (function (_ [module [module_id [descriptor document output]]]) + [module_id output])) + (monad.fold ! (..write_module sequence) header) + (\ ! map (|>> scope to_code (\ utf8.codec encode))))))) diff --git a/stdlib/source/library/lux/tool/compiler/phase.lux b/stdlib/source/library/lux/tool/compiler/phase.lux new file mode 100644 index 000000000..d69098f92 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/phase.lux @@ -0,0 +1,119 @@ +(.module: + [library + [lux #* + ["." debug] + [abstract + [monad (#+ Monad do)]] + [control + ["." state] + ["." try (#+ Try) ("#\." functor)] + ["ex" exception (#+ Exception exception:)] + ["." io] + [parser + ["s" code]]] + [data + ["." product] + ["." text + ["%" format (#+ format)]]] + [time + ["." instant] + ["." duration]] + [macro + [syntax (#+ syntax:)]]]] + [// + [meta + [archive (#+ Archive)]]]) + +(type: #export (Operation s o) + (state.State' Try s o)) + +(def: #export monad + (All [s] (Monad (Operation s))) + (state.with try.monad)) + +(type: #export (Phase s i o) + (-> Archive i (Operation s o))) + +(def: #export (run' state operation) + (All [s o] + (-> s (Operation s o) (Try [s o]))) + (operation state)) + +(def: #export (run state operation) + (All [s o] + (-> s (Operation s o) (Try o))) + (|> state + operation + (\ try.monad map product.right))) + +(def: #export get_state + (All [s o] + (Operation s s)) + (function (_ state) + (#try.Success [state state]))) + +(def: #export (set_state state) + (All [s o] + (-> s (Operation s Any))) + (function (_ _) + (#try.Success [state []]))) + +(def: #export (sub [get set] operation) + (All [s s' o] + (-> [(-> s s') (-> s' s s)] + (Operation s' o) + (Operation s o))) + (function (_ state) + (do try.monad + [[state' output] (operation (get state))] + (wrap [(set state' state) output])))) + +(def: #export fail + (-> Text Operation) + (|>> try.fail (state.lift try.monad))) + +(def: #export (throw exception parameters) + (All [e] (-> (Exception e) e Operation)) + (..fail (ex.construct exception parameters))) + +(def: #export (lift error) + (All [s a] (-> (Try a) (Operation s a))) + (function (_ state) + (try\map (|>> [state]) error))) + +(syntax: #export (assert exception message test) + (wrap (list (` (if (~ test) + (\ ..monad (~' wrap) []) + (..throw (~ exception) (~ message))))))) + +(def: #export identity + (All [s a] (Phase s a a)) + (function (_ archive input state) + (#try.Success [state input]))) + +(def: #export (compose pre post) + (All [s0 s1 i t o] + (-> (Phase s0 i t) + (Phase s1 t o) + (Phase [s0 s1] i o))) + (function (_ archive input [pre/state post/state]) + (do try.monad + [[pre/state' temp] (pre archive input pre/state) + [post/state' output] (post archive temp post/state)] + (wrap [[pre/state' post/state'] output])))) + +(def: #export (timed definition description operation) + (All [s a] + (-> Name Text (Operation s a) (Operation s a))) + (do ..monad + [_ (wrap []) + #let [pre (io.run instant.now)] + output operation + #let [_ (|> instant.now + io.run + instant.relative + (duration.difference (instant.relative pre)) + %.duration + (format (%.name definition) " [" description "]: ") + debug.log!)]] + (wrap output))) diff --git a/stdlib/source/library/lux/tool/compiler/reference.lux b/stdlib/source/library/lux/tool/compiler/reference.lux new file mode 100644 index 000000000..8823b29e2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/reference.lux @@ -0,0 +1,85 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] + [control + [pipe (#+ case>)]] + [data + ["." name] + [text + ["%" format (#+ Format)]]] + [math + [number + ["n" nat]]]]] + ["." / #_ + ["#." variable (#+ Variable)]]) + +(type: #export Constant + Name) + +(type: #export Reference + (#Variable Variable) + (#Constant Constant)) + +(implementation: #export equivalence + (Equivalence Reference) + + (def: (= reference sample) + (case [reference sample] + (^template [<tag> <equivalence>] + [[(<tag> reference) (<tag> sample)] + (\ <equivalence> = reference sample)]) + ([#Variable /variable.equivalence] + [#Constant name.equivalence]) + + _ + false))) + +(implementation: #export hash + (Hash Reference) + + (def: &equivalence + ..equivalence) + + (def: (hash value) + (case value + (^template [<factor> <tag> <hash>] + [(<tag> value) + ($_ n.* <factor> + (\ <hash> hash value))]) + ([2 #Variable /variable.hash] + [3 #Constant name.hash]) + ))) + +(template [<name> <family> <tag>] + [(template: #export (<name> content) + (<| <family> + <tag> + content))] + + [local #..Variable #/variable.Local] + [foreign #..Variable #/variable.Foreign] + ) + +(template [<name> <tag>] + [(template: #export (<name> content) + (<| <tag> + content))] + + [variable #..Variable] + [constant #..Constant] + ) + +(def: #export self + Reference + (..local 0)) + +(def: #export format + (Format Reference) + (|>> (case> (#Variable variable) + (/variable.format variable) + + (#Constant constant) + (%.name constant)))) diff --git a/stdlib/source/library/lux/tool/compiler/reference/variable.lux b/stdlib/source/library/lux/tool/compiler/reference/variable.lux new file mode 100644 index 000000000..a8ce4c049 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/reference/variable.lux @@ -0,0 +1,68 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] + [control + [pipe (#+ case>)]] + [data + [text + ["%" format (#+ Format)]]] + [math + [number + ["n" nat] + ["i" int]]]]]) + +(type: #export Register + Nat) + +(type: #export Variable + (#Local Register) + (#Foreign Register)) + +(implementation: #export equivalence + (Equivalence Variable) + + (def: (= reference sample) + (case [reference sample] + (^template [<tag>] + [[(<tag> reference') (<tag> sample')] + (n.= reference' sample')]) + ([#Local] [#Foreign]) + + _ + #0))) + +(implementation: #export hash + (Hash Variable) + + (def: &equivalence + ..equivalence) + + (def: hash + (|>> (case> (^template [<factor> <tag>] + [(<tag> register) + ($_ n.* <factor> + (\ n.hash hash register))]) + ([2 #Local] + [3 #Foreign]))))) + +(template: #export (self) + (#..Local 0)) + +(def: #export self? + (-> Variable Bit) + (|>> (case> (^ (..self)) + true + + _ + false))) + +(def: #export format + (Format Variable) + (|>> (case> (#Local local) + (%.format "+" (%.nat local)) + + (#Foreign foreign) + (%.format "-" (%.nat foreign))))) diff --git a/stdlib/source/library/lux/tool/compiler/version.lux b/stdlib/source/library/lux/tool/compiler/version.lux new file mode 100644 index 000000000..733b86477 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/version.lux @@ -0,0 +1,52 @@ +(.module: + [library + [lux #* + [data + [text + ["%" format]]] + [math + [number + ["n" nat]]]]]) + +(type: #export Version + Nat) + +(def: range 100) + +(def: level + (n.% ..range)) + +(def: current + (-> Nat Nat) + (|>>)) + +(def: next + (n./ ..range)) + +(def: #export patch + (-> Version Nat) + (|>> ..current ..level)) + +(def: #export minor + (-> Version Nat) + (|>> ..next ..level)) + +(def: #export major + (-> Version Nat) + (|>> ..next ..next ..level)) + +(def: separator ".") + +(def: (padded value) + (-> Nat Text) + (if (n.< 10 value) + (%.format "0" (%.nat value)) + (%.nat value))) + +(def: #export (format version) + (%.Format Version) + (%.format (..padded (..major version)) + ..separator + (..padded (..minor version)) + ..separator + (..padded (..patch version)))) diff --git a/stdlib/source/library/lux/tool/interpreter.lux b/stdlib/source/library/lux/tool/interpreter.lux new file mode 100644 index 000000000..df48eb420 --- /dev/null +++ b/stdlib/source/library/lux/tool/interpreter.lux @@ -0,0 +1,222 @@ +(.module: + [library + [lux #* + [control + [monad (#+ Monad do)] + ["." try (#+ Try)] + ["ex" exception (#+ exception:)]] + [data + ["." text ("#\." equivalence) + ["%" format (#+ format)]]] + [type (#+ :share) + ["." check]] + [compiler + ["." phase + ["." analysis + ["." module] + ["." type]] + ["." generation] + ["." directive (#+ State+ Operation) + ["." total]] + ["." extension]] + ["." default + ["." syntax] + ["." platform (#+ Platform)] + ["." init]] + ["." cli (#+ Configuration)]] + [world + ["." file (#+ File)] + ["." console (#+ Console)]]]] + ["." /type]) + +(exception: #export (error {message Text}) + message) + +(def: #export module "<INTERPRETER>") + +(def: fresh-source Source [[..module 1 0] 0 ""]) + +(def: (add-line line [where offset input]) + (-> Text Source Source) + [where offset (format input text.new-line line)]) + +(def: exit-command Text "exit") + +(def: welcome-message + Text + (format text.new-line + "Welcome to the interpreter!" text.new-line + "Type '" ..exit-command "' to leave." text.new-line + text.new-line)) + +(def: farewell-message + Text + "Till next time...") + +(def: enter-module + (All [anchor expression directive] + (Operation anchor expression directive Any)) + (directive.lift-analysis + (do phase.monad + [_ (module.create 0 ..module)] + (analysis.set-current-module ..module)))) + +(def: (initialize Monad<!> Console<!> platform configuration generation-bundle) + (All [! anchor expression directive] + (-> (Monad !) + (Console !) (Platform ! anchor expression directive) + Configuration + (generation.Bundle anchor expression directive) + (! (State+ anchor expression directive)))) + (do Monad<!> + [state (platform.initialize platform generation-bundle) + state (platform.compile platform + (set@ #cli.module syntax.prelude configuration) + (set@ [#extension.state + #directive.analysis #directive.state + #extension.state + #.info #.mode] + #.Interpreter + state)) + [state _] (\ (get@ #platform.file-system platform) + lift (phase.run' state enter-module)) + _ (\ Console<!> write ..welcome-message)] + (wrap state))) + +(with-expansions [<Interpretation> (as-is (Operation anchor expression directive [Type Any]))] + + (def: (interpret-directive code) + (All [anchor expression directive] + (-> Code <Interpretation>)) + (do phase.monad + [_ (total.phase code) + _ init.refresh] + (wrap [Any []]))) + + (def: (interpret-expression code) + (All [anchor expression directive] + (-> Code <Interpretation>)) + (do {! phase.monad} + [state (extension.lift phase.get-state) + #let [analyse (get@ [#directive.analysis #directive.phase] state) + synthesize (get@ [#directive.synthesis #directive.phase] state) + generate (get@ [#directive.generation #directive.phase] state)] + [_ codeT codeA] (directive.lift-analysis + (analysis.with-scope + (type.with-fresh-env + (do ! + [[codeT codeA] (type.with-inference + (analyse code)) + codeT (type.with-env + (check.clean codeT))] + (wrap [codeT codeA]))))) + codeS (directive.lift-synthesis + (synthesize codeA))] + (directive.lift-generation + (generation.with-buffer + (do ! + [codeH (generate codeS) + count generation.next + codeV (generation.evaluate! (format "interpretation_" (%.nat count)) codeH)] + (wrap [codeT codeV])))))) + + (def: (interpret configuration code) + (All [anchor expression directive] + (-> Configuration Code <Interpretation>)) + (function (_ state) + (case (<| (phase.run' state) + (:share [anchor expression directive] + {(State+ anchor expression directive) + state} + {<Interpretation> + (interpret-directive code)})) + (#try.Success [state' output]) + (#try.Success [state' output]) + + (#try.Failure error) + (if (ex.match? total.not-a-directive error) + (<| (phase.run' state) + (:share [anchor expression directive] + {(State+ anchor expression directive) + state} + {<Interpretation> + (interpret-expression code)})) + (#try.Failure error))))) + ) + +(def: (execute configuration code) + (All [anchor expression directive] + (-> Configuration Code (Operation anchor expression directive Text))) + (do phase.monad + [[codeT codeV] (interpret configuration code) + state phase.get-state] + (wrap (/type.represent (get@ [#extension.state + #directive.analysis #directive.state + #extension.state] + state) + codeT + codeV)))) + +(type: (Context anchor expression directive) + {#configuration Configuration + #state (State+ anchor expression directive) + #source Source}) + +(with-expansions [<Context> (as-is (Context anchor expression directive))] + (def: (read-eval-print context) + (All [anchor expression directive] + (-> <Context> (Try [<Context> Text]))) + (do try.monad + [#let [[_where _offset _code] (get@ #source context)] + [source' input] (syntax.parse ..module syntax.no-aliases (text.size _code) (get@ #source context)) + [state' representation] (let [## TODO: Simplify ASAP + state (:share [anchor expression directive] + {<Context> + context} + {(State+ anchor expression directive) + (get@ #state context)})] + (<| (phase.run' state) + ## TODO: Simplify ASAP + (:share [anchor expression directive] + {<Context> + context} + {(Operation anchor expression directive Text) + (execute (get@ #configuration context) input)})))] + (wrap [(|> context + (set@ #state state') + (set@ #source source')) + representation])))) + +(def: #export (run Monad<!> Console<!> platform configuration generation-bundle) + (All [! anchor expression directive] + (-> (Monad !) + (Console !) (Platform ! anchor expression directive) + Configuration + (generation.Bundle anchor expression directive) + (! Any))) + (do {! Monad<!>} + [state (initialize Monad<!> Console<!> platform configuration)] + (loop [context {#configuration configuration + #state state + #source ..fresh-source} + multi-line? #0] + (do ! + [_ (if multi-line? + (\ Console<!> write " ") + (\ Console<!> write "> ")) + line (\ Console<!> read-line)] + (if (and (not multi-line?) + (text\= ..exit-command line)) + (\ Console<!> write ..farewell-message) + (case (read-eval-print (update@ #source (add-line line) context)) + (#try.Success [context' representation]) + (do ! + [_ (\ Console<!> write representation)] + (recur context' #0)) + + (#try.Failure error) + (if (ex.match? syntax.end-of-file error) + (recur context #1) + (exec (log! (ex.construct ..error error)) + (recur (set@ #source ..fresh-source context) #0)))))) + ))) diff --git a/stdlib/source/library/lux/tool/mediator.lux b/stdlib/source/library/lux/tool/mediator.lux new file mode 100644 index 000000000..b24309ef1 --- /dev/null +++ b/stdlib/source/library/lux/tool/mediator.lux @@ -0,0 +1,19 @@ +(.module: + [library + [lux (#- Source Module) + [world + ["." binary (#+ Binary)] + ["." file (#+ File)]]]] + [// + [compiler (#+ Compiler) + [meta + ["." archive (#+ Archive) + [descriptor (#+ Module)]]]]]) + +(type: #export Source File) + +(type: #export (Mediator !) + (-> Archive Module (! Archive))) + +(type: #export (Instancer ! d o) + (-> (file.System !) (List Source) (Compiler d o) (Mediator !))) diff --git a/stdlib/source/library/lux/type.lux b/stdlib/source/library/lux/type.lux new file mode 100644 index 000000000..751645cc4 --- /dev/null +++ b/stdlib/source/library/lux/type.lux @@ -0,0 +1,463 @@ +(.module: {#.doc "Basic functionality for working with types."} + [library + [lux (#- function) + ["@" target] + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ Monad do)]] + [control + ["." function] + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text ("#\." monoid equivalence)] + ["." name ("#\." equivalence codec)] + [collection + ["." array] + ["." list ("#\." functor monoid fold)]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number + ["n" nat ("#\." decimal)]]] + ["." meta + ["." location]]]]) + +(template [<name> <tag>] + [(def: #export (<name> type) + (-> Type [Nat Type]) + (loop [num_args 0 + type type] + (case type + (<tag> env sub_type) + (recur (inc num_args) sub_type) + + _ + [num_args type])))] + + [flatten_univ_q #.UnivQ] + [flatten_ex_q #.ExQ] + ) + +(def: #export (flatten_function type) + (-> Type [(List Type) Type]) + (case type + (#.Function in out') + (let [[ins out] (flatten_function out')] + [(list& in ins) out]) + + _ + [(list) type])) + +(def: #export (flatten_application type) + (-> Type [Type (List Type)]) + (case type + (#.Apply arg func') + (let [[func args] (flatten_application func')] + [func (list\compose args (list arg))]) + + _ + [type (list)])) + +(template [<name> <tag>] + [(def: #export (<name> type) + (-> Type (List Type)) + (case type + (<tag> left right) + (list& left (<name> right)) + + _ + (list type)))] + + [flatten_variant #.Sum] + [flatten_tuple #.Product] + ) + +(def: #export (format type) + (-> Type Text) + (case type + (#.Primitive name params) + ($_ text\compose + "(primitive " + (text.enclose' text.double_quote name) + (|> params + (list\map (|>> format (text\compose " "))) + (list\fold (function.flip text\compose) "")) + ")") + + (^template [<tag> <open> <close> <flatten>] + [(<tag> _) + ($_ text\compose <open> + (|> (<flatten> type) + (list\map format) + list.reverse + (list.interpose " ") + (list\fold text\compose "")) + <close>)]) + ([#.Sum "(| " ")" flatten_variant] + [#.Product "[" "]" flatten_tuple]) + + (#.Function input output) + (let [[ins out] (flatten_function type)] + ($_ text\compose "(-> " + (|> ins + (list\map format) + list.reverse + (list.interpose " ") + (list\fold text\compose "")) + " " (format out) ")")) + + (#.Parameter idx) + (n\encode idx) + + (#.Var id) + ($_ text\compose "⌈v:" (n\encode id) "⌋") + + (#.Ex id) + ($_ text\compose "⟨e:" (n\encode id) "⟩") + + (#.Apply param fun) + (let [[type_func type_args] (flatten_application type)] + ($_ text\compose "(" (format type_func) " " (|> type_args (list\map format) list.reverse (list.interpose " ") (list\fold text\compose "")) ")")) + + (^template [<tag> <desc>] + [(<tag> env body) + ($_ text\compose "(" <desc> " {" (|> env (list\map format) (text.join_with " ")) "} " (format body) ")")]) + ([#.UnivQ "All"] + [#.ExQ "Ex"]) + + (#.Named [module name] type) + ($_ text\compose module "." name) + )) + +(def: (beta_reduce env type) + (-> (List Type) Type Type) + (case type + (#.Primitive name params) + (#.Primitive name (list\map (beta_reduce env) params)) + + (^template [<tag>] + [(<tag> left right) + (<tag> (beta_reduce env left) (beta_reduce env right))]) + ([#.Sum] [#.Product] + [#.Function] [#.Apply]) + + (^template [<tag>] + [(<tag> old_env def) + (case old_env + #.Nil + (<tag> env def) + + _ + (<tag> (list\map (beta_reduce env) old_env) def))]) + ([#.UnivQ] + [#.ExQ]) + + (#.Parameter idx) + (maybe.default (error! ($_ text\compose + "Unknown type parameter" text.new_line + " Index: " (n\encode idx) text.new_line + "Environment: " (|> env + list.enumeration + (list\map (.function (_ [index type]) + ($_ text\compose + (n\encode index) + " " (..format type)))) + (text.join_with (text\compose text.new_line " "))))) + (list.nth idx env)) + + _ + type + )) + +(implementation: #export equivalence + (Equivalence Type) + + (def: (= x y) + (or (for {@.php false} ## TODO: Remove this once JPHP is gone. + (is? x y)) + (case [x y] + [(#.Primitive xname xparams) (#.Primitive yname yparams)] + (and (text\= xname yname) + (n.= (list.size yparams) (list.size xparams)) + (list\fold (.function (_ [x y] prev) (and prev (= x y))) + #1 + (list.zip/2 xparams yparams))) + + (^template [<tag>] + [[(<tag> xid) (<tag> yid)] + (n.= yid xid)]) + ([#.Var] [#.Ex] [#.Parameter]) + + (^or [(#.Function xleft xright) (#.Function yleft yright)] + [(#.Apply xleft xright) (#.Apply yleft yright)]) + (and (= xleft yleft) + (= xright yright)) + + [(#.Named xname xtype) (#.Named yname ytype)] + (and (name\= xname yname) + (= xtype ytype)) + + (^template [<tag>] + [[(<tag> xL xR) (<tag> yL yR)] + (and (= xL yL) (= xR yR))]) + ([#.Sum] [#.Product]) + + (^or [(#.UnivQ xenv xbody) (#.UnivQ yenv ybody)] + [(#.ExQ xenv xbody) (#.ExQ yenv ybody)]) + (and (n.= (list.size yenv) (list.size xenv)) + (= xbody ybody) + (list\fold (.function (_ [x y] prev) (and prev (= x y))) + #1 + (list.zip/2 xenv yenv))) + + _ + #0 + )))) + +(def: #export (apply params func) + (-> (List Type) Type (Maybe Type)) + (case params + #.Nil + (#.Some func) + + (#.Cons param params') + (case func + (^template [<tag>] + [(<tag> env body) + (|> body + (beta_reduce (list& func param env)) + (apply params'))]) + ([#.UnivQ] [#.ExQ]) + + (#.Apply A F) + (apply (list& A params) F) + + (#.Named name unnamed) + (apply params unnamed) + + _ + #.None))) + +(def: #export (to_code type) + (-> Type Code) + (case type + (#.Primitive name params) + (` (#.Primitive (~ (code.text name)) + (.list (~+ (list\map to_code params))))) + + (^template [<tag>] + [(<tag> idx) + (` (<tag> (~ (code.nat idx))))]) + ([#.Var] [#.Ex] [#.Parameter]) + + (^template [<tag>] + [(<tag> left right) + (` (<tag> (~ (to_code left)) + (~ (to_code right))))]) + ([#.Sum] [#.Product] [#.Function] [#.Apply]) + + (#.Named name sub_type) + (code.identifier name) + + (^template [<tag>] + [(<tag> env body) + (` (<tag> (.list (~+ (list\map to_code env))) + (~ (to_code body))))]) + ([#.UnivQ] [#.ExQ]) + )) + +(def: #export (un_alias type) + (-> Type Type) + (case type + (#.Named _ (#.Named name type')) + (un_alias (#.Named name type')) + + _ + type)) + +(def: #export (un_name type) + (-> Type Type) + (case type + (#.Named name type') + (un_name type') + + _ + type)) + +(template [<name> <base> <ctor>] + [(def: #export (<name> types) + (-> (List Type) Type) + (case types + #.Nil + <base> + + (#.Cons type #.Nil) + type + + (#.Cons type types') + (<ctor> type (<name> types'))))] + + [variant Nothing #.Sum] + [tuple Any #.Product] + ) + +(def: #export (function inputs output) + (-> (List Type) Type Type) + (case inputs + #.Nil + output + + (#.Cons input inputs') + (#.Function input (function inputs' output)))) + +(def: #export (application params quant) + (-> (List Type) Type Type) + (case params + #.Nil + quant + + (#.Cons param params') + (application params' (#.Apply param quant)))) + +(template [<name> <tag>] + [(def: #export (<name> size body) + (-> Nat Type Type) + (case size + 0 body + _ (|> body (<name> (dec size)) (<tag> (list)))))] + + [univ_q #.UnivQ] + [ex_q #.ExQ] + ) + +(def: #export (quantified? type) + (-> Type Bit) + (case type + (#.Named [module name] _type) + (quantified? _type) + + (#.Apply A F) + (maybe.default #0 + (do maybe.monad + [applied (apply (list A) F)] + (wrap (quantified? applied)))) + + (^or (#.UnivQ _) (#.ExQ _)) + #1 + + _ + #0)) + +(def: #export (array depth element_type) + (-> Nat Type Type) + (case depth + 0 element_type + _ (|> element_type + (array (dec depth)) + (list) + (#.Primitive array.type_name)))) + +(def: #export (flatten_array type) + (-> Type [Nat Type]) + (case type + (^multi (^ (#.Primitive name (list element_type))) + (text\= array.type_name name)) + (let [[depth element_type] (flatten_array element_type)] + [(inc depth) element_type]) + + _ + [0 type])) + +(def: #export array? + (-> Type Bit) + (|>> ..flatten_array + product.left + (n.> 0))) + +(syntax: (new_secret_marker) + (macro.with_gensyms [g!_secret_marker_] + (wrap (list g!_secret_marker_)))) + +(def: secret_marker + (`` (name_of (~~ (new_secret_marker))))) + +(syntax: #export (:log! {input (<>.or (<>.and <code>.identifier + (<>.maybe (<>.after (<code>.identifier! ..secret_marker) <code>.any))) + <code>.any)}) + (case input + (#.Left [valueN valueC]) + (do meta.monad + [location meta.location + valueT (meta.find_type valueN) + #let [_ ("lux io log" + ($_ text\compose + (name\encode (name_of ..:log!)) " " (location.format location) text.new_line + "Expression: " (case valueC + (#.Some valueC) + (code.format valueC) + + #.None + (name\encode valueN)) + text.new_line + " Type: " (..format valueT)))]] + (wrap (list (code.identifier valueN)))) + + (#.Right valueC) + (macro.with_gensyms [g!value] + (wrap (list (` (.let [(~ g!value) (~ valueC)] + (..:log! (~ valueC) (~ (code.identifier ..secret_marker)) (~ g!value))))))))) + +(def: type_parameters + (Parser (List Text)) + (<code>.tuple (<>.some <code>.local_identifier))) + +(syntax: #export (:cast {type_vars type_parameters} + input + output + {value (<>.maybe <code>.any)}) + (let [casterC (` (: (All [(~+ (list\map code.local_identifier type_vars))] + (-> (~ input) (~ output))) + (|>> :assume)))] + (case value + #.None + (wrap (list casterC)) + + (#.Some value) + (wrap (list (` ((~ casterC) (~ value)))))))) + +(type: Typed + {#type Code + #expression Code}) + +(def: typed + (Parser Typed) + (<>.and <code>.any <code>.any)) + +## TODO: Make sure the generated code always gets optimized away. +(syntax: #export (:share {type_vars ..type_parameters} + {exemplar ..typed} + {computation ..typed}) + (macro.with_gensyms [g!_] + (let [shareC (` (: (All [(~+ (list\map code.local_identifier type_vars))] + (-> (~ (get@ #type exemplar)) + (~ (get@ #type computation)))) + (.function ((~ g!_) (~ g!_)) + (~ (get@ #expression computation)))))] + (wrap (list (` ((~ shareC) (~ (get@ #expression exemplar))))))))) + +(syntax: #export (:by_example {type_vars ..type_parameters} + {exemplar ..typed} + {extraction <code>.any}) + (wrap (list (` (:of ((~! :share) + [(~+ (list\map code.local_identifier type_vars))] + + (~ (get@ #type exemplar)) + (~ (get@ #expression exemplar)) + + (~ extraction) + (:assume []))))))) diff --git a/stdlib/source/library/lux/type/abstract.lux b/stdlib/source/library/lux/type/abstract.lux new file mode 100644 index 000000000..0bd4a505a --- /dev/null +++ b/stdlib/source/library/lux/type/abstract.lux @@ -0,0 +1,269 @@ +(.module: + [library + [lux #* + [type (#+ :cast)] + ["." meta] + [abstract + [monad (#+ Monad do)]] + [control + ["." exception (#+ exception:)] + ["<>" parser ("#\." monad) + ["<.>" code (#+ Parser)]]] + [data + ["." name ("#\." codec)] + ["." text ("#\." equivalence monoid)] + [collection + ["." list ("#\." functor monoid)]]] + [macro + ["." code] + [syntax (#+ syntax:) + ["|.|" export] + ["|.|" annotations]]]]]) + +(type: Stack List) + +(def: peek + (All [a] (-> (Stack a) (Maybe a))) + list.head) + +(def: (push value stack) + (All [a] (-> a (Stack a) (Stack a))) + (#.Cons value stack)) + +(def: pop + (All [a] (-> (Stack a) (Maybe (Stack a)))) + list.tail) + +(type: #export Frame + {#name Text + #type_vars (List Code) + #abstraction Code + #representation Code}) + +(def: frames + (Stack Frame) + #.Nil) + +(template: (!peek <source> <reference> <then>) + (loop [entries <source>] + (case entries + (#.Cons [head_name head] tail) + (if (text\= <reference> head_name) + <then> + (recur tail)) + + #.Nil + (undefined)))) + +(def: (peek_frames_definition reference source) + (-> Text (List [Text Global]) (Stack Frame)) + (!peek source reference + (case head + (#.Left _) + (undefined) + + (#.Right [exported? frame_type frame_anns frame_value]) + (:as (Stack Frame) frame_value)))) + +(def: (peek_frames reference definition_reference source) + (-> Text Text (List [Text Module]) (Stack Frame)) + (!peek source reference + (peek_frames_definition definition_reference (get@ #.definitions head)))) + +(exception: #export no_active_frames) + +(def: (peek! frame) + (-> (Maybe Text) (Meta Frame)) + (function (_ compiler) + (let [[reference definition_reference] (name_of ..frames) + current_frames (peek_frames reference definition_reference (get@ #.modules compiler))] + (case (case frame + (#.Some frame) + (list.find (function (_ [actual _]) + (text\= frame actual)) + current_frames) + + #.None + (..peek current_frames)) + (#.Some frame) + (#.Right [compiler frame]) + + #.None + (exception.throw ..no_active_frames []))))) + +(def: #export current + (Meta Frame) + (..peek! #.None)) + +(def: #export (specific name) + (-> Text (Meta Frame)) + (..peek! (#.Some name))) + +(template: (!push <source> <reference> <then>) + (loop [entries <source>] + (case entries + (#.Cons [head_name head] tail) + (if (text\= <reference> head_name) + (#.Cons [head_name <then>] + tail) + (#.Cons [head_name head] + (recur tail))) + + #.Nil + (undefined)))) + +(def: (push_frame_definition reference frame source) + (-> Text Frame (List [Text Global]) (List [Text Global])) + (!push source reference + (case head + (#.Left _) + (undefined) + + (#.Right [exported? frames_type frames_anns frames_value]) + (#.Right [exported? + frames_type + frames_anns + (..push frame (:as (Stack Frame) frames_value))])))) + +(def: (push_frame [module_reference definition_reference] frame source) + (-> Name Frame (List [Text Module]) (List [Text Module])) + (!push source module_reference + (update@ #.definitions (push_frame_definition definition_reference frame) head))) + +(def: (push! frame) + (-> Frame (Meta Any)) + (function (_ compiler) + (#.Right [(update@ #.modules + (..push_frame (name_of ..frames) frame) + compiler) + []]))) + +(def: (pop_frame_definition reference source) + (-> Text (List [Text Global]) (List [Text Global])) + (!push source reference + (case head + (#.Left _) + (undefined) + + (#.Right [exported? frames_type frames_anns frames_value]) + (#.Right [exported? + frames_type + frames_anns + (let [current_frames (:as (Stack Frame) frames_value)] + (case (..pop current_frames) + (#.Some current_frames') + current_frames' + + #.None + current_frames))])))) + +(def: (pop_frame [module_reference definition_reference] source) + (-> Name (List [Text Module]) (List [Text Module])) + (!push source module_reference + (|> head (update@ #.definitions (pop_frame_definition definition_reference))))) + +(syntax: (pop!) + (function (_ compiler) + (#.Right [(update@ #.modules + (..pop_frame (name_of ..frames)) + compiler) + (list)]))) + +(def: cast + (Parser [(Maybe Text) Code]) + (<>.either (<>.and (<>.maybe <code>.local_identifier) <code>.any) + (<>.and (<>\wrap #.None) <code>.any))) + +(template [<name> <from> <to>] + [(syntax: #export (<name> {[frame value] ..cast}) + (do meta.monad + [[name type_vars abstraction representation] (peek! frame)] + (wrap (list (` ((~! :cast) [(~+ type_vars)] (~ <from>) (~ <to>) + (~ value)))))))] + + [:abstraction representation abstraction] + [:representation abstraction representation] + ) + +(def: abstraction_type_name + (-> Name Text) + (|>> name\encode + ($_ text\compose + (name\encode (name_of #..Abstraction)) + " "))) + +(def: representation_definition_name + (-> Text Text) + (|>> ($_ text\compose + (name\encode (name_of #..Representation)) + " "))) + +(def: declaration + (Parser [Text (List Text)]) + (<>.either (<code>.form (<>.and <code>.local_identifier (<>.some <code>.local_identifier))) + (<>.and <code>.local_identifier (\ <>.monad wrap (list))))) + +## TODO: Make sure the generated code always gets optimized away. +## (This applies to uses of ":abstraction" and ":representation") +(syntax: #export (abstract: + {export |export|.parser} + {[name type_vars] declaration} + representation_type + {annotations (<>.default |annotations|.empty |annotations|.parser)} + {primitives (<>.some <code>.any)}) + (do meta.monad + [current_module meta.current_module_name + #let [type_varsC (list\map code.local_identifier type_vars) + abstraction_declaration (` ((~ (code.local_identifier name)) (~+ type_varsC))) + representation_declaration (` ((~ (code.local_identifier (representation_definition_name name))) + (~+ type_varsC)))] + _ (..push! [name + type_varsC + abstraction_declaration + representation_declaration])] + (wrap (list& (` (type: (~+ (|export|.format export)) (~ abstraction_declaration) + (~ (|annotations|.format annotations)) + (primitive (~ (code.text (abstraction_type_name [current_module name]))) + [(~+ type_varsC)]))) + (` (type: (~ representation_declaration) + (~ representation_type))) + ($_ list\compose + primitives + (list (` ((~! ..pop!))))))))) + +(type: (Selection a) + (#Specific Code a) + (#Current a)) + +(def: (selection parser) + (All [a] (-> (Parser a) (Parser (Selection a)))) + (<>.or (<>.and <code>.any parser) + parser)) + +(syntax: #export (:transmutation {selection (..selection <code>.any)}) + (case selection + (#Specific specific value) + (wrap (list (` (..:abstraction (~ specific) + (..:representation (~ specific) + (~ value)))))) + + (#Current value) + (wrap (list (` (..:abstraction (..:representation (~ value)))))))) + +(syntax: #export (^:representation {selection (<code>.form (..selection <code>.local_identifier))} + body + {branches (<>.some <code>.any)}) + (case selection + (#Specific specific name) + (let [g!var (code.local_identifier name)] + (wrap (list& g!var + (` (.let [(~ g!var) (..:representation (~ specific) (~ g!var))] + (~ body))) + branches))) + + (#Current name) + (let [g!var (code.local_identifier name)] + (wrap (list& g!var + (` (.let [(~ g!var) (..:representation (~ g!var))] + (~ body))) + branches))))) diff --git a/stdlib/source/library/lux/type/check.lux b/stdlib/source/library/lux/type/check.lux new file mode 100644 index 000000000..a8b447338 --- /dev/null +++ b/stdlib/source/library/lux/type/check.lux @@ -0,0 +1,721 @@ +(.module: {#.doc "Type-checking functionality."} + [library + [lux #* + ["@" target] + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + ["." monad (#+ Monad do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ Exception exception:)]] + [data + ["." maybe] + ["." product] + ["." text ("#\." monoid equivalence)] + [collection + ["." list] + ["." set (#+ Set)]]] + [math + [number + ["n" nat ("#\." decimal)]]]]] + ["." // ("#\." equivalence)]) + +(template: (!n\= reference subject) + ("lux i64 =" reference subject)) + +(template: (!text\= reference subject) + ("lux text =" reference subject)) + +(exception: #export (unknown_type_var {id Nat}) + (exception.report + ["ID" (n\encode id)])) + +(exception: #export (unbound_type_var {id Nat}) + (exception.report + ["ID" (n\encode id)])) + +(exception: #export (invalid_type_application {funcT Type} {argT Type}) + (exception.report + ["Type function" (//.format funcT)] + ["Type argument" (//.format argT)])) + +(exception: #export (cannot_rebind_var {id Nat} {type Type} {bound Type}) + (exception.report + ["Var" (n\encode id)] + ["Wanted Type" (//.format type)] + ["Current Type" (//.format bound)])) + +(exception: #export (type_check_failed {expected Type} {actual Type}) + (exception.report + ["Expected" (//.format expected)] + ["Actual" (//.format actual)])) + +(type: #export Var + Nat) + +(type: Assumption + [Type Type]) + +(type: #export (Check a) + (-> Type_Context (Try [Type_Context a]))) + +(type: (Checker a) + (-> (List Assumption) a a (Check (List Assumption)))) + +(type: Type_Vars + (List [Var (Maybe Type)])) + +(implementation: #export functor + (Functor Check) + + (def: (map f fa) + (function (_ context) + (case (fa context) + (#try.Success [context' output]) + (#try.Success [context' (f output)]) + + (#try.Failure error) + (#try.Failure error))))) + +(implementation: #export apply + (Apply Check) + + (def: &functor ..functor) + + (def: (apply ff fa) + (function (_ context) + (case (ff context) + (#try.Success [context' f]) + (case (fa context') + (#try.Success [context'' a]) + (#try.Success [context'' (f a)]) + + (#try.Failure error) + (#try.Failure error)) + + (#try.Failure error) + (#try.Failure error) + ))) + ) + +(implementation: #export monad + (Monad Check) + + (def: &functor ..functor) + + (def: (wrap x) + (function (_ context) + (#try.Success [context x]))) + + (def: (join ffa) + (function (_ context) + (case (ffa context) + (#try.Success [context' fa]) + (case (fa context') + (#try.Success [context'' a]) + (#try.Success [context'' a]) + + (#try.Failure error) + (#try.Failure error)) + + (#try.Failure error) + (#try.Failure error) + ))) + ) + +(open: "check\." ..monad) + +(def: (var::new id plist) + (-> Var Type_Vars Type_Vars) + (#.Cons [id #.None] plist)) + +(def: (var::get id plist) + (-> Var Type_Vars (Maybe (Maybe Type))) + (case plist + (#.Cons [var_id var_type] + plist') + (if (!n\= id var_id) + (#.Some var_type) + (var::get id plist')) + + #.Nil + #.None)) + +(def: (var::put id value plist) + (-> Var (Maybe Type) Type_Vars Type_Vars) + (case plist + #.Nil + (list [id value]) + + (#.Cons [var_id var_type] + plist') + (if (!n\= id var_id) + (#.Cons [var_id value] + plist') + (#.Cons [var_id var_type] + (var::put id value plist'))))) + +(def: #export (run context proc) + (All [a] (-> Type_Context (Check a) (Try a))) + (case (proc context) + (#try.Success [context' output]) + (#try.Success output) + + (#try.Failure error) + (#try.Failure error))) + +(def: #export (fail message) + (All [a] (-> Text (Check a))) + (function (_ context) + (#try.Failure message))) + +(def: #export (assert message test) + (-> Text Bit (Check Any)) + (function (_ context) + (if test + (#try.Success [context []]) + (#try.Failure message)))) + +(def: #export (throw exception message) + (All [e a] (-> (Exception e) e (Check a))) + (..fail (exception.construct exception message))) + +(def: #export existential + {#.doc "A producer of existential types."} + (Check [Nat Type]) + (function (_ context) + (let [id (get@ #.ex_counter context)] + (#try.Success [(update@ #.ex_counter inc context) + [id (#.Ex id)]])))) + +(template [<name> <outputT> <fail> <succeed>] + [(def: #export (<name> id) + (-> Var (Check <outputT>)) + (function (_ context) + (case (|> context (get@ #.var_bindings) (var::get id)) + (^or (#.Some (#.Some (#.Var _))) + (#.Some #.None)) + (#try.Success [context <fail>]) + + (#.Some (#.Some bound)) + (#try.Success [context <succeed>]) + + #.None + (exception.throw ..unknown_type_var id))))] + + [bound? Bit false true] + [read (Maybe Type) #.None (#.Some bound)] + ) + +(def: #export (read! id) + (-> Var (Check Type)) + (do ..monad + [?type (read id)] + (case ?type + (#.Some type) + (wrap type) + + #.None + (..throw ..unbound_type_var id)))) + +(def: (peek id) + (-> Var (Check Type)) + (function (_ context) + (case (|> context (get@ #.var_bindings) (var::get id)) + (#.Some (#.Some bound)) + (#try.Success [context bound]) + + (#.Some _) + (exception.throw ..unbound_type_var id) + + _ + (exception.throw ..unknown_type_var id)))) + +(def: #export (bind type id) + (-> Type Var (Check Any)) + (function (_ context) + (case (|> context (get@ #.var_bindings) (var::get id)) + (#.Some #.None) + (#try.Success [(update@ #.var_bindings (var::put id (#.Some type)) context) + []]) + + (#.Some (#.Some bound)) + (exception.throw ..cannot_rebind_var [id type bound]) + + _ + (exception.throw ..unknown_type_var id)))) + +(def: (update type id) + (-> Type Var (Check Any)) + (function (_ context) + (case (|> context (get@ #.var_bindings) (var::get id)) + (#.Some _) + (#try.Success [(update@ #.var_bindings (var::put id (#.Some type)) context) + []]) + + _ + (exception.throw ..unknown_type_var id)))) + +(def: #export var + (Check [Var Type]) + (function (_ context) + (let [id (get@ #.var_counter context)] + (#try.Success [(|> context + (update@ #.var_counter inc) + (update@ #.var_bindings (var::new id))) + [id (#.Var id)]])))) + +(def: (apply_type! funcT argT) + (-> Type Type (Check Type)) + (case funcT + (#.Var func_id) + (do ..monad + [?funcT' (read func_id)] + (case ?funcT' + (#.Some funcT') + (apply_type! funcT' argT) + + _ + (throw ..invalid_type_application [funcT argT]))) + + (#.Apply argT' funcT') + (do ..monad + [funcT'' (apply_type! funcT' argT')] + (apply_type! funcT'' argT)) + + _ + (case (//.apply (list argT) funcT) + (#.Some output) + (check\wrap output) + + _ + (throw ..invalid_type_application [funcT argT])))) + +(type: Ring + (Set Var)) + +(def: empty_ring + Ring + (set.new n.hash)) + +## TODO: Optimize this by not using sets anymore. +(def: (ring start) + (-> Var (Check Ring)) + (function (_ context) + (loop [current start + output (set.add start empty_ring)] + (case (|> context (get@ #.var_bindings) (var::get current)) + (#.Some (#.Some type)) + (case type + (#.Var post) + (if (!n\= start post) + (#try.Success [context output]) + (recur post (set.add post output))) + + _ + (#try.Success [context empty_ring])) + + (#.Some #.None) + (#try.Success [context output]) + + #.None + (exception.throw ..unknown_type_var current))))) + +(def: #export fresh_context + Type_Context + {#.var_counter 0 + #.ex_counter 0 + #.var_bindings (list)}) + +(def: (attempt op) + (All [a] (-> (Check a) (Check (Maybe a)))) + (function (_ context) + (case (op context) + (#try.Success [context' output]) + (#try.Success [context' (#.Some output)]) + + (#try.Failure _) + (#try.Success [context #.None])))) + +(def: (either left right) + (All [a] (-> (Check a) (Check a) (Check a))) + (function (_ context) + (case (left context) + (#try.Failure _) + (right context) + + output + output))) + +(def: (assumed? [e a] assumptions) + (-> Assumption (List Assumption) Bit) + (list.any? (function (_ [e' a']) + (and (//\= e e') + (//\= a a'))) + assumptions)) + +(def: (assume! assumption assumptions) + (-> Assumption (List Assumption) (List Assumption)) + (#.Cons assumption assumptions)) + +## TODO: "if_bind" can be optimized... +(def: (if_bind id type then else) + (All [a] + (-> Var Type (Check a) (-> Type (Check a)) + (Check a))) + ($_ either + (do ..monad + [_ (..bind type id)] + then) + (do {! ..monad} + [ring (..ring id) + _ (assert "" (n.> 1 (set.size ring))) + _ (monad.map ! (update type) (set.to_list ring))] + then) + (do ..monad + [?bound (read id)] + (else (maybe.default (#.Var id) ?bound))))) + +## TODO: "link_2" can be optimized... +(def: (link_2 left right) + (-> Var Var (Check Any)) + (do ..monad + [_ (..bind (#.Var right) left)] + (..bind (#.Var left) right))) + +## TODO: "link_3" can be optimized... +(def: (link_3 interpose to from) + (-> Var Var Var (Check Any)) + (do ..monad + [_ (update (#.Var interpose) from)] + (update (#.Var to) interpose))) + +## TODO: "check_vars" can be optimized... +(def: (check_vars check' assumptions idE idA) + (-> (Checker Type) (Checker Var)) + (if (!n\= idE idA) + (check\wrap assumptions) + (do {! ..monad} + [ebound (attempt (peek idE)) + abound (attempt (peek idA))] + (case [ebound abound] + ## Link the 2 variables circularly + [#.None #.None] + (do ! + [_ (link_2 idE idA)] + (wrap assumptions)) + + ## Interpose new variable between 2 existing links + [(#.Some etype) #.None] + (case etype + (#.Var targetE) + (do ! + [_ (link_3 idA targetE idE)] + (wrap assumptions)) + + _ + (check' assumptions etype (#.Var idA))) + + ## Interpose new variable between 2 existing links + [#.None (#.Some atype)] + (case atype + (#.Var targetA) + (do ! + [_ (link_3 idE targetA idA)] + (wrap assumptions)) + + _ + (check' assumptions (#.Var idE) atype)) + + [(#.Some etype) (#.Some atype)] + (case [etype atype] + [(#.Var targetE) (#.Var targetA)] + (do ! + [ringE (..ring idE) + ringA (..ring idA)] + (if (\ set.equivalence = ringE ringA) + (wrap assumptions) + ## Fuse 2 rings + (do ! + [_ (monad.fold ! (function (_ interpose to) + (do ! + [_ (link_3 interpose to idE)] + (wrap interpose))) + targetE + (set.to_list ringA))] + (wrap assumptions)))) + + (^template [<pattern> <id> <type>] + [<pattern> + (do ! + [ring (..ring <id>) + _ (monad.map ! (update <type>) (set.to_list ring))] + (wrap assumptions))]) + ([[(#.Var _) _] idE atype] + [[_ (#.Var _)] idA etype]) + + _ + (check' assumptions etype atype)))))) + +(def: silent_failure! + (All [a] (Check a)) + (..fail "")) + +## TODO: "check_apply" can be optimized... +(def: (check_apply check' assumptions expected actual) + (-> (Checker Type) (Checker [Type Type])) + (let [[expected_input expected_function] expected + [actual_input actual_function] actual] + (case [expected_function actual_function] + [(#.Ex exE) (#.Ex exA)] + (if (!n\= exE exA) + (check' assumptions expected_input actual_input) + ..silent_failure!) + + [(#.UnivQ _ _) (#.Ex _)] + (do ..monad + [expected' (apply_type! expected_function expected_input)] + (check' assumptions expected' (#.Apply actual))) + + [(#.Ex _) (#.UnivQ _ _)] + (do ..monad + [actual' (apply_type! actual_function actual_input)] + (check' assumptions (#.Apply expected) actual')) + + [(#.Apply [expected_input' expected_function']) (#.Ex _)] + (do ..monad + [expected_function'' (apply_type! expected_function' expected_input')] + (check' assumptions (#.Apply [expected_input expected_function'']) (#.Apply actual))) + + [(#.Ex _) (#.Apply [actual_input' actual_function'])] + (do ..monad + [actual_function'' (apply_type! actual_function' actual_input')] + (check' assumptions (#.Apply expected) (#.Apply [actual_input actual_function'']))) + + (^or [(#.Ex _) _] [_ (#.Ex _)]) + (do ..monad + [assumptions (check' assumptions expected_function actual_function)] + (check' assumptions expected_input actual_input)) + + [(#.Var id) _] + (function (_ context) + (case ((do ..monad + [expected_function' (..read! id)] + (check' assumptions (#.Apply expected_input expected_function') (#.Apply actual))) + context) + (#try.Success output) + (#try.Success output) + + (#try.Failure _) + (case actual_function + (#.UnivQ _ _) + ((do ..monad + [actual' (apply_type! actual_function actual_input)] + (check' assumptions (#.Apply expected) actual')) + context) + + (#.Ex exA) + ((do ..monad + [assumptions (check' assumptions expected_function actual_function)] + (check' assumptions expected_input actual_input)) + context) + + _ + ((do ..monad + [assumptions (check' assumptions expected_function actual_function) + expected' (apply_type! actual_function expected_input) + actual' (apply_type! actual_function actual_input)] + (check' assumptions expected' actual')) + context)))) + + [_ (#.Var id)] + (function (_ context) + (case ((do ..monad + [actual_function' (read! id)] + (check' assumptions (#.Apply expected) (#.Apply actual_input actual_function'))) + context) + (#try.Success output) + (#try.Success output) + + _ + ((do ..monad + [assumptions (check' assumptions expected_function actual_function) + expected' (apply_type! expected_function expected_input) + actual' (apply_type! expected_function actual_input)] + (check' assumptions expected' actual')) + context))) + + _ + ..silent_failure!))) + +(def: (with exception parameter check) + (All [e a] (-> (Exception e) e (Check a) (Check a))) + (|>> check (exception.with exception parameter))) + +## TODO: "check'" can be optimized... +(def: (check' assumptions expected actual) + {#.doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."} + (Checker Type) + (if (for {@.php false} ## TODO: Remove this once JPHP is gone. + (is? expected actual)) + (check\wrap assumptions) + (with ..type_check_failed [expected actual] + (case [expected actual] + [(#.Var idE) (#.Var idA)] + (check_vars check' assumptions idE idA) + + [(#.Var id) _] + (if_bind id actual + (check\wrap assumptions) + (function (_ bound) + (check' assumptions bound actual))) + + [_ (#.Var id)] + (if_bind id expected + (check\wrap assumptions) + (function (_ bound) + (check' assumptions expected bound))) + + (^template [<fE> <fA>] + [[(#.Apply aE <fE>) (#.Apply aA <fA>)] + (check_apply check' assumptions [aE <fE>] [aA <fA>])]) + ([F1 (#.Ex ex)] + [(#.Ex exE) fA] + [fE (#.Var idA)] + [(#.Var idE) fA]) + + [(#.Apply A F) _] + (let [new_assumption [expected actual]] + (if (assumed? new_assumption assumptions) + (check\wrap assumptions) + (do ..monad + [expected' (apply_type! F A)] + (check' (assume! new_assumption assumptions) expected' actual)))) + + [_ (#.Apply A F)] + (do ..monad + [actual' (apply_type! F A)] + (check' assumptions expected actual')) + + ## TODO: Refactor-away as cold-code + (^template [<tag> <instancer>] + [[(<tag> _) _] + (do ..monad + [[_ paramT] <instancer> + expected' (apply_type! expected paramT)] + (check' assumptions expected' actual))]) + ([#.UnivQ ..existential] + [#.ExQ ..var]) + + ## TODO: Refactor-away as cold-code + (^template [<tag> <instancer>] + [[_ (<tag> _)] + (do ..monad + [[_ paramT] <instancer> + actual' (apply_type! actual paramT)] + (check' assumptions expected actual'))]) + ([#.UnivQ ..var] + [#.ExQ ..existential]) + + [(#.Primitive e_name e_params) (#.Primitive a_name a_params)] + (if (!text\= e_name a_name) + (loop [assumptions assumptions + e_params e_params + a_params a_params] + (case [e_params a_params] + [#.Nil #.Nil] + (check\wrap assumptions) + + [(#.Cons e_head e_tail) (#.Cons a_head a_tail)] + (do ..monad + [assumptions' (check' assumptions e_head a_head)] + (recur assumptions' e_tail a_tail)) + + _ + ..silent_failure!)) + ..silent_failure!) + + (^template [<compose>] + [[(<compose> eL eR) (<compose> aL aR)] + (do ..monad + [assumptions (check' assumptions eL aL)] + (check' assumptions eR aR))]) + ([#.Sum] + [#.Product]) + + [(#.Function eI eO) (#.Function aI aO)] + (do ..monad + [assumptions (check' assumptions aI eI)] + (check' assumptions eO aO)) + + [(#.Ex e!id) (#.Ex a!id)] + (if (!n\= e!id a!id) + (check\wrap assumptions) + ..silent_failure!) + + [(#.Named _ ?etype) _] + (check' assumptions ?etype actual) + + [_ (#.Named _ ?atype)] + (check' assumptions expected ?atype) + + _ + ..silent_failure!)))) + +(def: #export (check expected actual) + {#.doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."} + (-> Type Type (Check Any)) + (check' (list) expected actual)) + +(def: #export (checks? expected actual) + {#.doc "A simple type-checking function that just returns a yes/no answer."} + (-> Type Type Bit) + (case (..run ..fresh_context (..check' (list) expected actual)) + (#try.Failure _) + false + + (#try.Success _) + true)) + +(def: #export context + (Check Type_Context) + (function (_ context) + (#try.Success [context context]))) + +(def: #export (clean inputT) + (-> Type (Check Type)) + (case inputT + (#.Primitive name paramsT+) + (|> paramsT+ + (monad.map ..monad clean) + (check\map (|>> (#.Primitive name)))) + + (^or (#.Parameter _) (#.Ex _) (#.Named _)) + (check\wrap inputT) + + (^template [<tag>] + [(<tag> leftT rightT) + (do ..monad + [leftT' (clean leftT)] + (|> (clean rightT) + (check\map (|>> (<tag> leftT')))))]) + ([#.Sum] [#.Product] [#.Function] [#.Apply]) + + (#.Var id) + (do ..monad + [?actualT (read id)] + (case ?actualT + (#.Some actualT) + (clean actualT) + + _ + (wrap inputT))) + + (^template [<tag>] + [(<tag> envT+ unquantifiedT) + (do {! ..monad} + [envT+' (monad.map ! clean envT+)] + (wrap (<tag> envT+' unquantifiedT)))]) + ([#.UnivQ] [#.ExQ]) + )) diff --git a/stdlib/source/library/lux/type/dynamic.lux b/stdlib/source/library/lux/type/dynamic.lux new file mode 100644 index 000000000..b5a6e7fc0 --- /dev/null +++ b/stdlib/source/library/lux/type/dynamic.lux @@ -0,0 +1,51 @@ +(.module: + [library + [lux #* + ["." debug] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + [text + ["%" format]]] + [macro (#+ with_gensyms) + ["." syntax (#+ syntax:)]] + ["." type + abstract]]]) + +(exception: #export (wrong_type {expected Type} {actual Type}) + (exception.report + ["Expected" (%.type expected)] + ["Actual" (%.type actual)])) + +(abstract: #export Dynamic + [Type Any] + + {#.doc "A value coupled with its type, so it can be checked later."} + + (def: abstraction (-> [Type Any] Dynamic) (|>> :abstraction)) + (def: representation (-> Dynamic [Type Any]) (|>> :representation)) + + (syntax: #export (:dynamic value) + {#.doc (doc (: Dynamic + (:dynamic 123)))} + (with_gensyms [g!value] + (wrap (list (` (let [(~ g!value) (~ value)] + ((~! ..abstraction) [(:of (~ g!value)) (~ g!value)]))))))) + + (syntax: #export (:check type value) + {#.doc (doc (: (try.Try Nat) + (:check Nat (:dynamic 123))))} + (with_gensyms [g!type g!value] + (wrap (list (` (let [[(~ g!type) (~ g!value)] ((~! ..representation) (~ value))] + (: ((~! try.Try) (~ type)) + (if (\ (~! type.equivalence) (~' =) + (.type (~ type)) (~ g!type)) + (#try.Success (:as (~ type) (~ g!value))) + ((~! exception.throw) ..wrong_type [(.type (~ type)) (~ g!type)]))))))))) + + (def: #export (format value) + (-> Dynamic (Try Text)) + (let [[type value] (:representation value)] + (debug.represent type value))) + ) diff --git a/stdlib/source/library/lux/type/implicit.lux b/stdlib/source/library/lux/type/implicit.lux new file mode 100644 index 000000000..a308b99a8 --- /dev/null +++ b/stdlib/source/library/lux/type/implicit.lux @@ -0,0 +1,401 @@ +(.module: + [library + [lux #* + [abstract + ["." monad (#+ Monad do)] + ["eq" equivalence]] + [control + ["." try] + ["p" parser + ["s" code (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." list ("#\." monad fold)] + ["." dictionary (#+ Dictionary)]]] + ["." macro + ["." code] + [syntax (#+ syntax:)]] + [math + ["." number + ["n" nat]]] + ["." meta + ["." annotation]] + ["." type + ["." check (#+ Check)]]]]) + +(def: (find_type_var id env) + (-> Nat Type_Context (Meta Type)) + (case (list.find (|>> product.left (n.= id)) + (get@ #.var_bindings env)) + (#.Some [_ (#.Some type)]) + (case type + (#.Var id') + (find_type_var id' env) + + _ + (\ meta.monad wrap type)) + + (#.Some [_ #.None]) + (meta.fail (format "Unbound type-var " (%.nat id))) + + #.None + (meta.fail (format "Unknown type-var " (%.nat id))) + )) + +(def: (resolve_type var_name) + (-> Name (Meta Type)) + (do meta.monad + [raw_type (meta.find_type var_name) + compiler meta.get_compiler] + (case raw_type + (#.Var id) + (find_type_var id (get@ #.type_context compiler)) + + _ + (wrap raw_type)))) + +(def: (find_member_type idx sig_type) + (-> Nat Type (Check Type)) + (case sig_type + (#.Named _ sig_type') + (find_member_type idx sig_type') + + (#.Apply arg func) + (case (type.apply (list arg) func) + #.None + (check.fail (format "Cannot apply type " (%.type func) " to type " (%.type arg))) + + (#.Some sig_type') + (find_member_type idx sig_type')) + + (#.Product left right) + (if (n.= 0 idx) + (\ check.monad wrap left) + (find_member_type (dec idx) right)) + + _ + (if (n.= 0 idx) + (\ check.monad wrap sig_type) + (check.fail (format "Cannot find member type " (%.nat idx) " for " (%.type sig_type)))))) + +(def: (find_member_name member) + (-> Name (Meta Name)) + (case member + ["" simple_name] + (meta.either (do meta.monad + [member (meta.normalize member) + _ (meta.resolve_tag member)] + (wrap member)) + (do {! meta.monad} + [this_module_name meta.current_module_name + imp_mods (meta.imported_modules this_module_name) + tag_lists (monad.map ! meta.tag_lists imp_mods) + #let [tag_lists (|> tag_lists list\join (list\map product.left) list\join) + candidates (list.filter (|>> product.right (text\= simple_name)) + tag_lists)]] + (case candidates + #.Nil + (meta.fail (format "Unknown tag: " (%.name member))) + + (#.Cons winner #.Nil) + (wrap winner) + + _ + (meta.fail (format "Too many candidate tags: " (%.list %.name candidates)))))) + + _ + (\ meta.monad wrap member))) + +(def: (resolve_member member) + (-> Name (Meta [Nat Type])) + (do meta.monad + [member (find_member_name member) + [idx tag_list sig_type] (meta.resolve_tag member)] + (wrap [idx sig_type]))) + +(def: (prepare_definitions source_module target_module constants aggregate) + (-> Text Text (List [Text Definition]) (-> (List [Name Type]) (List [Name Type]))) + (list\fold (function (_ [name [exported? def_type def_anns def_value]] aggregate) + (if (and (annotation.implementation? def_anns) + (or (text\= target_module source_module) + exported?)) + (#.Cons [[source_module name] def_type] aggregate) + aggregate)) + aggregate + constants)) + +(def: local_env + (Meta (List [Name Type])) + (do meta.monad + [local_batches meta.locals + #let [total_locals (list\fold (function (_ [name type] table) + (try.default table (dictionary.try_put name type table))) + (: (Dictionary Text Type) + (dictionary.new text.hash)) + (list\join local_batches))]] + (wrap (|> total_locals + dictionary.entries + (list\map (function (_ [name type]) [["" name] type])))))) + +(def: local_structs + (Meta (List [Name Type])) + (do {! meta.monad} + [this_module_name meta.current_module_name + definitions (meta.definitions this_module_name)] + (wrap (prepare_definitions this_module_name this_module_name definitions #.Nil)))) + +(def: imported_structs + (Meta (List [Name Type])) + (do {! meta.monad} + [this_module_name meta.current_module_name + imported_modules (meta.imported_modules this_module_name) + accessible_definitions (monad.map ! meta.definitions imported_modules)] + (wrap (list\fold (function (_ [imported_module definitions] tail) + (prepare_definitions imported_module this_module_name definitions tail)) + #.Nil + (list.zip/2 imported_modules accessible_definitions))))) + +(def: (apply_function_type func arg) + (-> Type Type (Check Type)) + (case func + (#.Named _ func') + (apply_function_type func' arg) + + (#.UnivQ _) + (do check.monad + [[id var] check.var] + (apply_function_type (maybe.assume (type.apply (list var) func)) + arg)) + + (#.Function input output) + (do check.monad + [_ (check.check input arg)] + (wrap output)) + + _ + (check.fail (format "Invalid function type: " (%.type func))))) + +(def: (concrete_type type) + (-> Type (Check [(List Nat) Type])) + (case type + (#.UnivQ _) + (do check.monad + [[id var] check.var + [ids final_output] (concrete_type (maybe.assume (type.apply (list var) type)))] + (wrap [(#.Cons id ids) + final_output])) + + _ + (\ check.monad wrap [(list) type]))) + +(def: (check_apply member_type input_types output_type) + (-> Type (List Type) Type (Check [])) + (do check.monad + [member_type' (monad.fold check.monad + (function (_ input member) + (apply_function_type member input)) + member_type + input_types)] + (check.check output_type member_type'))) + +(type: #rec Instance + {#constructor Name + #dependencies (List Instance)}) + +(def: (test_provision provision context dep alts) + (-> (-> Lux Type_Context Type (Check Instance)) + Type_Context Type (List [Name Type]) + (Meta (List Instance))) + (do meta.monad + [compiler meta.get_compiler] + (case (|> alts + (list\map (function (_ [alt_name alt_type]) + (case (check.run context + (do {! check.monad} + [[tvars alt_type] (concrete_type alt_type) + #let [[deps alt_type] (type.flatten_function alt_type)] + _ (check.check dep alt_type) + context' check.context + =deps (monad.map ! (provision compiler context') deps)] + (wrap =deps))) + (#.Left error) + (list) + + (#.Right =deps) + (list [alt_name =deps])))) + list\join) + #.Nil + (meta.fail (format "No candidates for provisioning: " (%.type dep))) + + found + (wrap found)))) + +(def: (provision compiler context dep) + (-> Lux Type_Context Type (Check Instance)) + (case (meta.run compiler + ($_ meta.either + (do meta.monad [alts ..local_env] (..test_provision provision context dep alts)) + (do meta.monad [alts ..local_structs] (..test_provision provision context dep alts)) + (do meta.monad [alts ..imported_structs] (..test_provision provision context dep alts)))) + (#.Left error) + (check.fail error) + + (#.Right candidates) + (case candidates + #.Nil + (check.fail (format "No candidates for provisioning: " (%.type dep))) + + (#.Cons winner #.Nil) + (\ check.monad wrap winner) + + _ + (check.fail (format "Too many candidates for provisioning: " (%.type dep) " --- " (%.list (|>> product.left %.name) candidates)))) + )) + +(def: (test_alternatives sig_type member_idx input_types output_type alts) + (-> Type Nat (List Type) Type (List [Name Type]) (Meta (List Instance))) + (do meta.monad + [compiler meta.get_compiler + context meta.type_context] + (case (|> alts + (list\map (function (_ [alt_name alt_type]) + (case (check.run context + (do {! check.monad} + [[tvars alt_type] (concrete_type alt_type) + #let [[deps alt_type] (type.flatten_function alt_type)] + _ (check.check alt_type sig_type) + member_type (find_member_type member_idx alt_type) + _ (check_apply member_type input_types output_type) + context' check.context + =deps (monad.map ! (provision compiler context') deps)] + (wrap =deps))) + (#.Left error) + (list) + + (#.Right =deps) + (list [alt_name =deps])))) + list\join) + #.Nil + (meta.fail (format "No alternatives for " (%.type (type.function input_types output_type)))) + + found + (wrap found)))) + +(def: (find_alternatives sig_type member_idx input_types output_type) + (-> Type Nat (List Type) Type (Meta (List Instance))) + (let [test (test_alternatives sig_type member_idx input_types output_type)] + ($_ meta.either + (do meta.monad [alts ..local_env] (test alts)) + (do meta.monad [alts ..local_structs] (test alts)) + (do meta.monad [alts ..imported_structs] (test alts))))) + +(def: (var? input) + (-> Code Bit) + (case input + [_ (#.Identifier _)] + #1 + + _ + #0)) + +(def: (join_pair [l r]) + (All [a] (-> [a a] (List a))) + (list l r)) + +(def: (instance$ [constructor dependencies]) + (-> Instance Code) + (case dependencies + #.Nil + (code.identifier constructor) + + _ + (` ((~ (code.identifier constructor)) (~+ (list\map instance$ dependencies)))))) + +(syntax: #export (\\ + {member s.identifier} + {args (p.or (p.and (p.some s.identifier) s.end!) + (p.and (p.some s.any) s.end!))}) + {#.doc (doc "Automatic implementation selection (for type-class style polymorphism)." + "This feature layers type-class style polymorphism on top of Lux's signatures and implementations." + "When calling a polymorphic function, or using a polymorphic constant," + "this macro will check the types of the arguments, and the expected type for the whole expression" + "and it will search in the local scope, the module's scope and the imports' scope" + "in order to find suitable implementations to satisfy those requirements." + "If a single alternative is found, that one will be used automatically." + "If no alternative is found, or if more than one alternative is found (ambiguity)" + "a compile-time error will be raised, to alert the user." + "Examples:" + "Nat equivalence" + (\ number.equivalence = x y) + (\\ = x y) + "Can optionally add the prefix of the module where the signature was defined." + (\\ eq.= x y) + "(List Nat) equivalence" + (\\ = + (list.indices 10) + (list.indices 10)) + "(Functor List) map" + (\\ map inc (list.indices 10)) + "Caveat emptor: You need to make sure to import the module of any implementation you want to use." + "Otherwise, this macro will not find it.")} + (case args + (#.Left [args _]) + (do {! meta.monad} + [[member_idx sig_type] (resolve_member member) + input_types (monad.map ! resolve_type args) + output_type meta.expected_type + chosen_ones (find_alternatives sig_type member_idx input_types output_type)] + (case chosen_ones + #.Nil + (meta.fail (format "No implementation could be found for member: " (%.name member))) + + (#.Cons chosen #.Nil) + (wrap (list (` (\ (~ (instance$ chosen)) + (~ (code.local_identifier (product.right member))) + (~+ (list\map code.identifier args)))))) + + _ + (meta.fail (format "Too many implementations available: " + (|> chosen_ones + (list\map (|>> product.left %.name)) + (text.join_with ", ")) + " --- for type: " (%.type sig_type))))) + + (#.Right [args _]) + (do {! meta.monad} + [labels (|> (macro.gensym "") (list.repeat (list.size args)) (monad.seq !))] + (wrap (list (` (let [(~+ (|> (list.zip/2 labels args) (list\map join_pair) list\join))] + (..\\ (~ (code.identifier member)) (~+ labels))))))) + )) + +(def: (implicit_bindings amount) + (-> Nat (Meta (List Code))) + (|> (macro.gensym "g!implicit") + (list.repeat amount) + (monad.seq meta.monad))) + +(def: implicits + (Parser (List Code)) + (s.tuple (p.many s.any))) + +(syntax: #export (with {implementations ..implicits} body) + (do meta.monad + [g!implicit+ (implicit_bindings (list.size implementations))] + (wrap (list (` (let [(~+ (|> (list.zip/2 g!implicit+ implementations) + (list\map (function (_ [g!implicit implementation]) + (list g!implicit implementation))) + list\join))] + (~ body))))))) + +(syntax: #export (implicit: {implementations ..implicits}) + (do meta.monad + [g!implicit+ (implicit_bindings (list.size implementations))] + (wrap (|> (list.zip/2 g!implicit+ implementations) + (list\map (function (_ [g!implicit implementation]) + (` (def: (~ g!implicit) + {#.implementation? #1} + (~ implementation))))))))) diff --git a/stdlib/source/library/lux/type/quotient.lux b/stdlib/source/library/lux/type/quotient.lux new file mode 100644 index 000000000..b872e6ff1 --- /dev/null +++ b/stdlib/source/library/lux/type/quotient.lux @@ -0,0 +1,56 @@ +(.module: + [library + [lux (#- type) + [abstract + [equivalence (#+ Equivalence)]] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)]] + ["." type + abstract]]]) + +(abstract: #export (Class t c %) + (-> t c) + + (def: #export class + (All [t c] + (Ex [%] + (-> (-> t c) (Class t c %)))) + (|>> :abstraction)) + + (abstract: #export (Quotient t c %) + {#value t + #label c} + + (def: #export (quotient class value) + (All [t c %] + (-> (Class t c %) t + (Quotient t c %))) + (:abstraction {#value value + #label ((:representation Class class) value)})) + + (template [<name> <output> <slot>] + [(def: #export <name> + (All [t c %] (-> (Quotient t c %) <output>)) + (|>> :representation (get@ <slot>)))] + + [value t #value] + [label c #label] + ) + ) + ) + +(syntax: #export (type class) + (with_gensyms [g!t g!c g!%] + (wrap (list (` ((~! type.:by_example) + [(~ g!t) (~ g!c) (~ g!%)] + + (..Class (~ g!t) (~ g!c) (~ g!%)) + (~ class) + + (..Quotient (~ g!t) (~ g!c) (~ g!%)))))))) + +(implementation: #export (equivalence super) + (All [t c %] (-> (Equivalence c) (Equivalence (..Quotient t c %)))) + + (def: (= reference sample) + (\ super = (..label reference) (..label sample)))) diff --git a/stdlib/source/library/lux/type/refinement.lux b/stdlib/source/library/lux/type/refinement.lux new file mode 100644 index 000000000..a3e49104d --- /dev/null +++ b/stdlib/source/library/lux/type/refinement.lux @@ -0,0 +1,89 @@ +(.module: + [library + [lux (#- type) + [abstract + [predicate (#+ Predicate)]] + ["." macro + [syntax (#+ syntax:)]] + ["." type + abstract]]]) + +(abstract: #export (Refined t %) + {#value t + #predicate (Predicate t)} + + {#.doc "A refined type '%' of base type 't' using a predicate."} + + (type: #export (Refiner t %) + (-> t (Maybe (Refined t %)))) + + (def: #export (refinement predicate) + (All [t] + (Ex [%] + (-> (Predicate t) (Refiner t %)))) + (function (_ un_refined) + (if (predicate un_refined) + (#.Some (:abstraction {#value un_refined + #predicate predicate})) + #.None))) + + (template [<name> <output> <slot>] + [(def: #export <name> + (All [t %] (-> (Refined t %) <output>)) + (|>> :representation (get@ <slot>)))] + + [un_refine t #value] + [predicate (Predicate t) #predicate] + ) + + (def: #export (lift transform) + (All [t %] + (-> (-> t t) + (-> (Refined t %) (Maybe (Refined t %))))) + (function (_ refined) + (let [(^slots [#value #predicate]) (:representation refined) + value' (transform value)] + (if (predicate value') + (#.Some (:abstraction {#value value' + #predicate predicate})) + #.None)))) + ) + +(def: #export (filter refiner values) + (All [t %] (-> (Refiner t %) (List t) (List (Refined t %)))) + (case values + #.Nil + #.Nil + + (#.Cons head tail) + (case (refiner head) + (#.Some refined) + (#.Cons refined (filter refiner tail)) + + #.None + (filter refiner tail)))) + +(def: #export (partition refiner values) + (All [t %] (-> (Refiner t %) (List t) [(List (Refined t %)) (List t)])) + (case values + #.Nil + [#.Nil #.Nil] + + (#.Cons head tail) + (let [[yes no] (partition refiner tail)] + (case (refiner head) + (#.Some refined) + [(#.Cons refined yes) + no] + + #.None + [yes + (#.Cons head no)])))) + +(syntax: #export (type refiner) + (macro.with_gensyms [g!t g!%] + (wrap (list (` ((~! type.:by_example) [(~ g!t) (~ g!%)] + (..Refiner (~ g!t) (~ g!%)) + (~ refiner) + + (..Refined (~ g!t) (~ g!%)))))))) diff --git a/stdlib/source/library/lux/type/resource.lux b/stdlib/source/library/lux/type/resource.lux new file mode 100644 index 000000000..5a2b79c1d --- /dev/null +++ b/stdlib/source/library/lux/type/resource.lux @@ -0,0 +1,218 @@ +(.module: + [library + [lux #* + ["." meta] + [abstract + ["." monad (#+ Monad do) + [indexed (#+ IxMonad)]]] + [control + ["." exception (#+ exception:)] + ["." io (#+ IO)] + [concurrency + ["." promise (#+ Promise)]] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." identity (#+ Identity)] + ["." maybe] + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." set] + ["." row (#+ Row)] + ["." list ("#\." functor fold)]]] + ["." macro + [syntax (#+ syntax:)]] + [math + [number + ["n" nat]]] + [type + abstract]]]) + +(type: #export (Procedure monad input output value) + (-> input (monad [output value]))) + +(type: #export (Linear monad value) + (All [keys] + (Procedure monad keys keys value))) + +(type: #export (Affine monad permissions value) + (All [keys] + (Procedure monad keys [permissions keys] value))) + +(type: #export (Relevant monad permissions value) + (All [keys] + (Procedure monad [permissions keys] keys value))) + +(implementation: (indexed Monad<m>) + (All [m] (-> (Monad m) (IxMonad (Procedure m)))) + + (def: (wrap value) + (function (_ keys) + (\ Monad<m> wrap [keys value]))) + + (def: (bind f input) + (function (_ keysI) + (do Monad<m> + [[keysT value] (input keysI)] + ((f value) keysT))))) + +(template [<name> <m> <monad> <execute> <lift>] + [(def: #export <name> + (IxMonad (Procedure <m>)) + (..indexed <monad>)) + + (def: #export (<execute> procedure) + (All [v] (-> (Linear <m> v) (<m> v))) + (do <monad> + [[_ output] (procedure [])] + (wrap output))) + + (def: #export (<lift> procedure) + (All [v] (-> (<m> v) (Linear <m> v))) + (function (_ keys) + (do <monad> + [output procedure] + (wrap [keys output]))))] + + [pure Identity identity.monad run_pure lift_pure] + [sync IO io.monad run_sync lift_sync] + [async Promise promise.monad run_async lift_async] + ) + +(abstract: #export Ordered Any) + +(abstract: #export Commutative Any) + +(abstract: #export (Key mode key) + Any + + (template [<name> <mode>] + [(def: <name> + (Ex [k] (-> Any (Key <mode> k))) + (|>> :abstraction))] + + [ordered_key Ordered] + [commutative_key Commutative] + )) + +(abstract: #export (Res key value) + value + + {#.doc "A value locked by a key."} + + (template [<name> <m> <monad> <mode> <key>] + [(def: #export (<name> value) + (All [v] (Ex [k] (-> v (Affine <m> (Key <mode> k) (Res k v))))) + (function (_ keys) + (\ <monad> wrap [[(<key> []) keys] (:abstraction value)])))] + + [ordered_pure Identity identity.monad Ordered ordered_key] + [ordered_sync IO io.monad Ordered ordered_key] + [ordered_async Promise promise.monad Ordered ordered_key] + [commutative_sync IO io.monad Commutative commutative_key] + [commutative_pure Identity identity.monad Commutative commutative_key] + [commutative_async Promise promise.monad Commutative commutative_key] + ) + + (template [<name> <m> <monad>] + [(def: #export (<name> resource) + (All [v k m] + (-> (Res k v) (Relevant <m> (Key m k) v))) + (function (_ [key keys]) + (\ <monad> wrap [keys (:representation resource)])))] + + [read_pure Identity identity.monad] + [read_sync IO io.monad] + [read_async Promise promise.monad] + )) + +(exception: #export (index_cannot_be_repeated {index Nat}) + (exception.report + ["Index" (%.nat index)])) + +(exception: #export amount_cannot_be_zero) + +(def: indices + (Parser (List Nat)) + (<code>.tuple (loop [seen (set.new n.hash)] + (do {! <>.monad} + [done? <code>.end?] + (if done? + (wrap (list)) + (do ! + [head <code>.nat + _ (<>.assert (exception.construct ..index_cannot_be_repeated head) + (not (set.member? seen head))) + tail (recur (set.add head seen))] + (wrap (list& head tail)))))))) + +(def: (no_op Monad<m>) + (All [m] (-> (Monad m) (Linear m Any))) + (function (_ context) + (\ Monad<m> wrap [context []]))) + +(template [<name> <m> <monad>] + [(syntax: #export (<name> {swaps ..indices}) + (macro.with_gensyms [g!_ g!context] + (case swaps + #.Nil + (wrap (list (` ((~! no_op) <monad>)))) + + (#.Cons head tail) + (do {! meta.monad} + [#let [max_idx (list\fold n.max head tail)] + g!inputs (<| (monad.seq !) (list.repeat (inc max_idx)) (macro.gensym "input")) + #let [g!outputs (|> (monad.fold maybe.monad + (function (_ from to) + (do maybe.monad + [input (list.nth from g!inputs)] + (wrap (row.add input to)))) + (: (Row Code) row.empty) + swaps) + maybe.assume + row.to_list) + g!inputsT+ (list\map (|>> (~) (..Key ..Commutative) (`)) g!inputs) + g!outputsT+ (list\map (|>> (~) (..Key ..Commutative) (`)) g!outputs)]] + (wrap (list (` (: (All [(~+ g!inputs) (~ g!context)] + (Procedure (~! <m>) + [(~+ g!inputsT+) (~ g!context)] + [(~+ g!outputsT+) (~ g!context)] + .Any)) + (function ((~ g!_) [(~+ g!inputs) (~ g!context)]) + (\ (~! <monad>) (~' wrap) [[(~+ g!outputs) (~ g!context)] []]))))))))))] + + [exchange_pure Identity identity.monad] + [exchange_sync IO io.monad] + [exchange_async Promise promise.monad] + ) + +(def: amount + (Parser Nat) + (do <>.monad + [raw <code>.nat + _ (<>.assert (exception.construct ..amount_cannot_be_zero []) + (n.> 0 raw))] + (wrap raw))) + +(template [<name> <m> <monad> <from> <to>] + [(syntax: #export (<name> {amount ..amount}) + (macro.with_gensyms [g!_ g!context] + (do {! meta.monad} + [g!keys (<| (monad.seq !) (list.repeat amount) (macro.gensym "keys"))] + (wrap (list (` (: (All [(~+ g!keys) (~ g!context)] + (Procedure (~! <m>) + [<from> (~ g!context)] + [<to> (~ g!context)] + .Any)) + (function ((~ g!_) [<from> (~ g!context)]) + (\ (~! <monad>) (~' wrap) [[<to> (~ g!context)] []])))))))))] + + [group_pure Identity identity.monad (~+ g!keys) [(~+ g!keys)]] + [group_sync IO io.monad (~+ g!keys) [(~+ g!keys)]] + [group_async Promise promise.monad (~+ g!keys) [(~+ g!keys)]] + [un_group_pure Identity identity.monad [(~+ g!keys)] (~+ g!keys)] + [un_group_sync IO io.monad [(~+ g!keys)] (~+ g!keys)] + [un_group_async Promise promise.monad [(~+ g!keys)] (~+ g!keys)] + ) diff --git a/stdlib/source/library/lux/type/unit.lux b/stdlib/source/library/lux/type/unit.lux new file mode 100644 index 000000000..ccdb34d46 --- /dev/null +++ b/stdlib/source/library/lux/type/unit.lux @@ -0,0 +1,188 @@ +(.module: + [library + [lux #* + ["." meta] + [abstract + [monad (#+ Monad do)] + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [enum (#+ Enum)]] + [control + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + [text + ["%" format (#+ format)]]] + [macro + ["." code] + [syntax (#+ syntax:) + ["|.|" export] + ["|.|" annotations]]] + [math + [number + ["n" nat] + ["i" int] + ["." ratio (#+ Ratio)]]] + [type + abstract]]]) + +(abstract: #export (Qty unit) + Int + + (def: in + (All [unit] (-> Int (Qty unit))) + (|>> :abstraction)) + + (def: out + (All [unit] (-> (Qty unit) Int)) + (|>> :representation)) + + (template [<name> <op>] + [(def: #export (<name> param subject) + (All [unit] (-> (Qty unit) (Qty unit) (Qty unit))) + (:abstraction (<op> (:representation param) + (:representation subject))))] + + [+ i.+] + [- i.-] + ) + + (template [<name> <op> <p> <s> <p*s>] + [(def: #export (<name> param subject) + (All [p s] (-> (Qty <p>) (Qty <s>) (Qty <p*s>))) + (:abstraction (<op> (:representation param) + (:representation subject))))] + + [* i.* p s [p s]] + [/ i./ p [p s] s] + ) + ) + +(interface: #export (Unit a) + (: (-> Int (Qty a)) + in) + (: (-> (Qty a) Int) + out)) + +(interface: #export (Scale s) + (: (All [u] (-> (Qty u) (Qty (s u)))) + scale) + (: (All [u] (-> (Qty (s u)) (Qty u))) + de_scale) + (: Ratio + ratio)) + +(type: #export Pure + (Qty Any)) + +(def: #export pure + (-> Int Pure) + ..in) + +(def: #export number + (-> Pure Int) + ..out) + +(syntax: #export (unit: + {export |export|.parser} + {type_name <code>.local_identifier} + {unit_name <code>.local_identifier} + {annotations (<>.default |annotations|.empty |annotations|.parser)}) + (do meta.monad + [@ meta.current_module_name + #let [g!type (code.local_identifier type_name)]] + (wrap (list (` (type: (~+ (|export|.format export)) (~ g!type) + (~ (|annotations|.format annotations)) + (primitive (~ (code.text (%.name [@ type_name])))))) + + (` (implementation: (~+ (|export|.format export)) (~ (code.local_identifier unit_name)) + (..Unit (~ g!type)) + + (def: (~' in) (~! ..in)) + (def: (~' out) (~! ..out)))) + )))) + +(def: scale + (Parser Ratio) + (<code>.tuple (do <>.monad + [numerator <code>.nat + _ (<>.assert (format "Numerator must be positive: " (%.nat numerator)) + (n.> 0 numerator)) + denominator <code>.nat + _ (<>.assert (format "Denominator must be positive: " (%.nat denominator)) + (n.> 0 denominator))] + (wrap [numerator denominator])))) + +(syntax: #export (scale: + {export |export|.parser} + {type_name <code>.local_identifier} + {scale_name <code>.local_identifier} + {(^slots [#ratio.numerator #ratio.denominator]) ..scale} + {annotations (<>.default |annotations|.empty |annotations|.parser)}) + (do meta.monad + [@ meta.current_module_name + #let [g!scale (code.local_identifier type_name)]] + (wrap (list (` (type: (~+ (|export|.format export)) ((~ g!scale) (~' u)) + (~ (|annotations|.format annotations)) + (primitive (~ (code.text (%.name [@ type_name]))) [(~' u)]))) + + (` (implementation: (~+ (|export|.format export)) (~ (code.local_identifier scale_name)) + (..Scale (~ g!scale)) + + (def: (~' scale) + (|>> ((~! ..out)) + (i.* (~ (code.int (.int numerator)))) + (i./ (~ (code.int (.int denominator)))) + ((~! ..in)))) + (def: (~' de_scale) + (|>> ((~! ..out)) + (i.* (~ (code.int (.int denominator)))) + (i./ (~ (code.int (.int numerator)))) + ((~! ..in)))) + (def: (~' ratio) + [(~ (code.nat numerator)) (~ (code.nat denominator))]))) + )))) + +(def: #export (re_scale from to quantity) + (All [si so u] (-> (Scale si) (Scale so) (Qty (si u)) (Qty (so u)))) + (let [[numerator denominator] (ratio./ (\ from ratio) + (\ to ratio))] + (|> quantity + out + (i.* (.int numerator)) + (i./ (.int denominator)) + in))) + +(scale: #export Kilo kilo [1 1,000]) +(scale: #export Mega mega [1 1,000,000]) +(scale: #export Giga giga [1 1,000,000,000]) + +(scale: #export Milli milli [ 1,000 1]) +(scale: #export Micro micro [ 1,000,000 1]) +(scale: #export Nano nano [1,000,000,000 1]) + +(unit: #export Gram gram) +(unit: #export Meter meter) +(unit: #export Litre litre) +(unit: #export Second second) + +(implementation: #export equivalence + (All [unit] (Equivalence (Qty unit))) + + (def: (= reference sample) + (i.= (..out reference) (..out sample)))) + +(implementation: #export order + (All [unit] (Order (Qty unit))) + + (def: &equivalence ..equivalence) + + (def: (< reference sample) + (i.< (..out reference) (..out sample)))) + +(implementation: #export enum + (All [unit] (Enum (Qty unit))) + + (def: &order ..order) + (def: succ (|>> ..out inc ..in)) + (def: pred (|>> ..out dec ..in))) diff --git a/stdlib/source/library/lux/type/variance.lux b/stdlib/source/library/lux/type/variance.lux new file mode 100644 index 000000000..406717046 --- /dev/null +++ b/stdlib/source/library/lux/type/variance.lux @@ -0,0 +1,12 @@ +(.module: + [library + [lux #*]]) + +(type: #export (Co t) + (-> Any t)) + +(type: #export (Contra t) + (-> t Any)) + +(type: #export (In t) + (-> t t)) diff --git a/stdlib/source/library/lux/world/console.lux b/stdlib/source/library/lux/world/console.lux new file mode 100644 index 000000000..41652fdd7 --- /dev/null +++ b/stdlib/source/library/lux/world/console.lux @@ -0,0 +1,159 @@ +(.module: + [library + [lux #* + [ffi (#+ import:)] + ["@" target] + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["." io (#+ IO io)] + [concurrency + ["." promise (#+ Promise)] + ["." atom]]] + [data + ["." text (#+ Char) + ["%" format (#+ format)]]]]]) + +(template [<name>] + [(exception: #export (<name>) + "")] + + [cannot_open] + [cannot_close] + ) + +(interface: #export (Console !) + (: (-> [] (! (Try Char))) + read) + (: (-> [] (! (Try Text))) + read_line) + (: (-> Text (! (Try Any))) + write) + (: (-> [] (! (Try Any))) + close)) + +(def: #export (async console) + (-> (Console IO) (Console Promise)) + (`` (implementation + (~~ (template [<capability>] + [(def: <capability> + (|>> (\ console <capability>) promise.future))] + + [read] + [read_line] + [write] + [close]))))) + +(with_expansions [<jvm> (as_is (import: java/lang/String) + + (import: java/io/Console + ["#::." + (readLine [] #io #try java/lang/String)]) + + (import: java/io/InputStream + ["#::." + (read [] #io #try int)]) + + (import: java/io/PrintStream + ["#::." + (print [java/lang/String] #io #try void)]) + + (import: java/lang/System + ["#::." + (#static console [] #io #? java/io/Console) + (#static in java/io/InputStream) + (#static out java/io/PrintStream)]) + + (def: #export default + (IO (Try (Console IO))) + (do io.monad + [?jvm_console (java/lang/System::console)] + (case ?jvm_console + #.None + (wrap (exception.throw ..cannot_open [])) + + (#.Some jvm_console) + (let [jvm_input (java/lang/System::in) + jvm_output (java/lang/System::out)] + (<| wrap + exception.return + (: (Console IO)) ## TODO: Remove ASAP + (implementation + (def: (read _) + (|> jvm_input + java/io/InputStream::read + (\ (try.with io.monad) map .nat))) + + (def: (read_line _) + (java/io/Console::readLine jvm_console)) + + (def: (write message) + (java/io/PrintStream::print message jvm_output)) + + (def: close + (|>> (exception.throw ..cannot_close) wrap)))))))))] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>)} + (as_is))) + +(def: #export (write_line message console) + (All [!] (-> Text (Console !) (! (Try Any)))) + (\ console write (format message text.new_line))) + +(interface: #export (Mock s) + (: (-> s (Try [s Char])) + on_read) + (: (-> s (Try [s Text])) + on_read_line) + (: (-> Text s (Try s)) + on_write) + (: (-> s (Try s)) + on_close)) + +(def: #export (mock mock init) + (All [s] (-> (Mock s) s (Console IO))) + (let [state (atom.atom init)] + (`` (implementation + (~~ (template [<method> <mock>] + [(def: (<method> _) + (do {! io.monad} + [|state| (atom.read state)] + (case (\ mock <mock> |state|) + (#try.Success [|state| output]) + (do ! + [_ (atom.write |state| state)] + (wrap (#try.Success output))) + + (#try.Failure error) + (wrap (#try.Failure error)))))] + + [read on_read] + [read_line on_read_line] + )) + + (def: (write input) + (do {! io.monad} + [|state| (atom.read state)] + (case (\ mock on_write input |state|) + (#try.Success |state|) + (do ! + [_ (atom.write |state| state)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error))))) + + (def: (close _) + (do {! io.monad} + [|state| (atom.read state)] + (case (\ mock on_close |state|) + (#try.Success |state|) + (do ! + [_ (atom.write |state| state)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error))))) + )))) diff --git a/stdlib/source/library/lux/world/db/jdbc.lux b/stdlib/source/library/lux/world/db/jdbc.lux new file mode 100644 index 000000000..5ef233daf --- /dev/null +++ b/stdlib/source/library/lux/world/db/jdbc.lux @@ -0,0 +1,176 @@ +(.module: + [library + [lux (#- and int) + [control + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)] + ["." try (#+ Try)] + ["ex" exception] + [concurrency + ["." promise (#+ Promise) ("#\." monad)]] + [security + ["!" capability (#+ capability:)]]] + [data + ["." product] + [text + ["%" format (#+ format)]]] + ["." io (#+ IO)] + [world + [net (#+ URL)]] + [host (#+ import:)]]] + [// + ["." sql]] + ["." / #_ + ["#." input (#+ Input)] + ["#." output (#+ Output)]]) + +(import: java/lang/String) + +(import: java/sql/ResultSet + (getRow [] #try int) + (next [] #try boolean) + (close [] #io #try void)) + +(import: java/sql/Statement + (#static NO_GENERATED_KEYS int) + (#static RETURN_GENERATED_KEYS int) + (getGeneratedKeys [] #try java/sql/ResultSet) + (close [] #io #try void)) + +(import: java/sql/PreparedStatement + (executeUpdate [] #io #try int) + (executeQuery [] #io #try java/sql/ResultSet)) + +(import: java/sql/Connection + (prepareStatement [java/lang/String int] #try java/sql/PreparedStatement) + (isValid [int] #try boolean) + (close [] #io #try void)) + +(import: java/sql/DriverManager + (#static getConnection [java/lang/String java/lang/String java/lang/String] #io #try java/sql/Connection)) + +(type: #export Credentials + {#url URL + #user Text + #password Text}) + +(type: #export ID Int) + +(type: #export (Statement input) + {#sql sql.Statement + #input (Input input) + #value input}) + +(template [<name> <forge> <output>] + [(capability: #export (<name> ! i) + (<forge> (Statement i) (! (Try <output>))))] + + [Can-Execute can-execute Nat] + [Can-Insert can-insert (List ID)] + ) + +(capability: #export (Can-Query ! i o) + (can-query [(Statement i) (Output o)] (! (Try (List o))))) + +(capability: #export (Can-Close !) + (can-close Any (! (Try Any)))) + +(interface: #export (DB !) + (: (Can-Execute !) + execute) + (: (Can-Insert !) + insert) + (: (Can-Query !) + query) + (: (Can-Close !) + close)) + +(def: (with-statement statement conn action) + (All [i a] + (-> (Statement i) java/sql/Connection + (-> java/sql/PreparedStatement (IO (Try a))) + (IO (Try a)))) + (do (try.with io.monad) + [prepared (io.io (java/sql/Connection::prepareStatement (sql.sql (get@ #sql statement)) + (java/sql/Statement::RETURN_GENERATED_KEYS) + conn)) + _ (io.io ((get@ #input statement) (get@ #value statement) [1 prepared])) + result (action prepared) + _ (java/sql/Statement::close prepared)] + (wrap result))) + +(def: #export (async db) + (-> (DB IO) (DB Promise)) + (`` (implementation + (~~ (template [<name> <forge>] + [(def: <name> (<forge> (|>> (!.use (\ db <name>)) promise.future)))] + + [execute can-execute] + [insert can-insert] + [close can-close] + [query can-query]))))) + +(def: #export (connect creds) + (-> Credentials (IO (Try (DB IO)))) + (do (try.with io.monad) + [connection (java/sql/DriverManager::getConnection (get@ #url creds) + (get@ #user creds) + (get@ #password creds))] + (wrap (: (DB IO) + (implementation + (def: execute + (..can-execute + (function (execute statement) + (with-statement statement connection + (function (_ prepared) + (do (try.with io.monad) + [row-count (java/sql/PreparedStatement::executeUpdate prepared)] + (wrap (.nat row-count)))))))) + + (def: insert + (..can-insert + (function (insert statement) + (with-statement statement connection + (function (_ prepared) + (do (try.with io.monad) + [_ (java/sql/PreparedStatement::executeUpdate prepared) + result-set (io.io (java/sql/Statement::getGeneratedKeys prepared))] + (/output.rows /output.long result-set))))))) + + (def: close + (..can-close + (function (close _) + (java/sql/Connection::close connection)))) + + (def: query + (..can-query + (function (query [statement output]) + (with-statement statement connection + (function (_ prepared) + (do (try.with io.monad) + [result-set (java/sql/PreparedStatement::executeQuery prepared)] + (/output.rows output result-set))))))) + ))))) + +(def: #export (with-db creds action) + (All [a] + (-> Credentials + (-> (DB IO) (IO (Try a))) + (IO (Try a)))) + (do (try.with io.monad) + [db (..connect creds) + result (action db) + _ (!.use (\ db close) [])] + (wrap result))) + +(def: #export (with-async-db creds action) + (All [a] + (-> Credentials + (-> (DB Promise) (Promise (Try a))) + (Promise (Try a)))) + (do (try.with promise.monad) + [db (promise.future (..connect creds)) + result (action (..async db)) + _ (promise\wrap (io.run (!.use (\ db close) [])))] + (wrap result))) diff --git a/stdlib/source/library/lux/world/db/jdbc/input.lux b/stdlib/source/library/lux/world/db/jdbc/input.lux new file mode 100644 index 000000000..9c3de1238 --- /dev/null +++ b/stdlib/source/library/lux/world/db/jdbc/input.lux @@ -0,0 +1,107 @@ +(.module: + [library + [lux (#- and int) + [ffi (#+ import:)] + [control + [functor (#+ Contravariant)] + [monad (#+ Monad do)] + ["." try (#+ Try)]] + [time + ["." instant (#+ Instant)]] + ["." io (#+ IO)] + [world + [binary (#+ Binary)]]]]) + +(import: java/lang/String) + +(template [<class>] + [(import: <class> + (new [long]))] + + [java/sql/Date] [java/sql/Time] [java/sql/Timestamp] + ) + +(`` (import: java/sql/PreparedStatement + (~~ (template [<name> <type>] + [(<name> [int <type>] #try void)] + + [setBoolean boolean] + + [setByte byte] + [setShort short] + [setInt int] + [setLong long] + + [setFloat float] + [setDouble double] + + [setString java/lang/String] + [setBytes [byte]] + + [setDate java/sql/Date] + [setTime java/sql/Time] + [setTimestamp java/sql/Timestamp] + )))) + +(type: #export (Input a) + (-> a [Nat java/sql/PreparedStatement] + (Try [Nat java/sql/PreparedStatement]))) + +(implementation: #export contravariant (Contravariant Input) + (def: (map-1 f fb) + (function (fa value circumstance) + (fb (f value) circumstance)))) + +(def: #export (and pre post) + (All [l r] (-> (Input l) (Input r) (Input [l r]))) + (function (_ [left right] context) + (do try.monad + [context (pre left context)] + (post right context)))) + +(def: #export (fail error) + (All [a] (-> Text (Input a))) + (function (_ value [idx context]) + (#try.Failure error))) + +(def: #export empty + (Input Any) + (function (_ value context) + (#try.Success context))) + +(template [<function> <type> <setter>] + [(def: #export <function> + (Input <type>) + (function (_ value [idx statement]) + (do try.monad + [_ (<setter> (.int idx) value statement)] + (wrap [(.inc idx) statement]))))] + + [boolean Bit java/sql/PreparedStatement::setBoolean] + + [byte Int java/sql/PreparedStatement::setByte] + [short Int java/sql/PreparedStatement::setShort] + [int Int java/sql/PreparedStatement::setInt] + [long Int java/sql/PreparedStatement::setLong] + + [float Frac java/sql/PreparedStatement::setFloat] + [double Frac java/sql/PreparedStatement::setDouble] + + [string Text java/sql/PreparedStatement::setString] + [bytes Binary java/sql/PreparedStatement::setBytes] + ) + +(template [<function> <setter> <constructor>] + [(def: #export <function> + (Input Instant) + (function (_ value [idx statement]) + (do try.monad + [_ (<setter> (.int idx) + (<constructor> (instant.to-millis value)) + statement)] + (wrap [(.inc idx) statement]))))] + + [date java/sql/PreparedStatement::setDate java/sql/Date::new] + [time java/sql/PreparedStatement::setTime java/sql/Time::new] + [time-stamp java/sql/PreparedStatement::setTimestamp java/sql/Timestamp::new] + ) diff --git a/stdlib/source/library/lux/world/db/jdbc/output.lux b/stdlib/source/library/lux/world/db/jdbc/output.lux new file mode 100644 index 000000000..b172a1ac9 --- /dev/null +++ b/stdlib/source/library/lux/world/db/jdbc/output.lux @@ -0,0 +1,195 @@ +(.module: + [library + [lux (#- and int) + [ffi (#+ import:)] + [control + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)] + ["ex" exception] + ["." try (#+ Try)]] + [time + ["." instant (#+ Instant)]] + ["." io (#+ IO)] + [world + [binary (#+ Binary)]]]]) + +(import: java/lang/String) + +(import: java/util/Date + (getTime [] long)) + +(import: java/sql/Date) +(import: java/sql/Time) +(import: java/sql/Timestamp) + +(`` (import: java/sql/ResultSet + (~~ (template [<method-name> <return-class>] + [(<method-name> [int] #try <return-class>)] + + [getBoolean boolean] + + [getByte byte] + [getShort short] + [getInt int] + [getLong long] + + [getDouble double] + [getFloat float] + + [getString java/lang/String] + [getBytes [byte]] + + [getDate java/sql/Date] + [getTime java/sql/Time] + [getTimestamp java/sql/Timestamp] + )) + (next [] #try boolean) + (close [] #io #try void))) + +(type: #export (Output a) + (-> [Nat java/sql/ResultSet] (Try [Nat a]))) + +(implementation: #export functor + (Functor Output) + + (def: (map f fa) + (function (_ idx+rs) + (case (fa idx+rs) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [idx' value]) + (#try.Success [idx' (f value)]))))) + +(implementation: #export apply + (Apply Output) + + (def: &functor ..functor) + + (def: (apply ff fa) + (function (_ [idx rs]) + (case (ff [idx rs]) + (#try.Success [idx' f]) + (case (fa [idx' rs]) + (#try.Success [idx'' a]) + (#try.Success [idx'' (f a)]) + + (#try.Failure msg) + (#try.Failure msg)) + + (#try.Failure msg) + (#try.Failure msg))))) + +(implementation: #export monad + (Monad Output) + + (def: &functor ..functor) + + (def: (wrap a) + (function (_ [idx rs]) + (#.Some [idx a]))) + + (def: (join mma) + (function (_ [idx rs]) + (case (mma [idx rs]) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [idx' ma]) + (ma [idx' rs]))))) + +(def: #export (fail error) + (All [a] (-> Text (Output a))) + (function (_ [idx result-set]) + (#try.Failure error))) + +(def: #export (and left right) + (All [a b] + (-> (Output a) (Output b) (Output [a b]))) + (do ..monad + [=left left + =right right] + (wrap [=left =right]))) + +(template [<func-name> <method-name> <type>] + [(def: #export <func-name> + (Output <type>) + (function (_ [idx result-set]) + (case (<method-name> [(.int idx)] result-set) + (#try.Failure error) + (#try.Failure error) + + (#try.Success value) + (#try.Success [(inc idx) value]))))] + + [boolean java/sql/ResultSet::getBoolean Bit] + + [byte java/sql/ResultSet::getByte Int] + [short java/sql/ResultSet::getShort Int] + [int java/sql/ResultSet::getInt Int] + [long java/sql/ResultSet::getLong Int] + + [float java/sql/ResultSet::getFloat Frac] + [double java/sql/ResultSet::getDouble Frac] + + [string java/sql/ResultSet::getString Text] + [bytes java/sql/ResultSet::getBytes Binary] + ) + +(template [<func-name> <method-name>] + [(def: #export <func-name> + (Output Instant) + (function (_ [idx result-set]) + (case (<method-name> [(.int idx)] result-set) + (#try.Failure error) + (#try.Failure error) + + (#try.Success value) + (#try.Success [(inc idx) + (instant.from-millis (java/util/Date::getTime value))]))))] + + [date java/sql/ResultSet::getDate] + [time java/sql/ResultSet::getTime] + [time-stamp java/sql/ResultSet::getTimestamp] + ) + +(def: #export (rows output results) + (All [a] (-> (Output a) java/sql/ResultSet (IO (Try (List a))))) + (case (java/sql/ResultSet::next results) + (#try.Success has-next?) + (if has-next? + (case (output [1 results]) + (#.Some [_ head]) + (do io.monad + [?tail (rows output results)] + (case ?tail + (#try.Success tail) + (wrap (ex.return (#.Cons head tail))) + + (#try.Failure error) + (do io.monad + [temp (java/sql/ResultSet::close results)] + (wrap (do try.monad + [_ temp] + (try.fail error)))))) + + (#try.Failure error) + (do io.monad + [temp (java/sql/ResultSet::close results)] + (wrap (do try.monad + [_ temp] + (try.fail error))))) + (do io.monad + [temp (java/sql/ResultSet::close results)] + (wrap (do try.monad + [_ temp] + (wrap (list)))))) + + (#try.Failure error) + (do io.monad + [temp (java/sql/ResultSet::close results)] + (wrap (do try.monad + [_ temp] + (try.fail error)))) + )) diff --git a/stdlib/source/library/lux/world/db/sql.lux b/stdlib/source/library/lux/world/db/sql.lux new file mode 100644 index 000000000..99f3f027d --- /dev/null +++ b/stdlib/source/library/lux/world/db/sql.lux @@ -0,0 +1,476 @@ +(.module: + [library + [lux (#- Source Definition function and or not type is? int) + [control + [monad (#+ do)]] + [data + [number + ["i" int]] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor)]]] + [type + abstract]]]) + +(def: parenthesize + (-> Text Text) + (text.enclose ["(" ")"])) + +## Kind +(template [<declaration>] + [(abstract: #export <declaration> Any)] + + [Literal'] + [Column'] + [Placeholder'] + [(Value' kind)] + + [Function'] + + [Condition'] + + [Index'] + + [Table'] + [View'] + [Source'] + [DB'] + + [No-Limit] [With-Limit] + [No-Offset] [With-Offset] + [Order'] + [No-Order] [With-Order] + [No-Group] [With-Group] + [(Query' order group limit offset)] + + [Command'] + + [No-Where] [With-Where] [Without-Where] + [No-Having] [With-Having] [Without-Having] + [(Action' where having kind)] + + [(Schema' kind)] + [Definition'] + [(Statement' kind)] + ) + +(type: #export Alias Text) + +(def: #export no-alias Alias "") + +(abstract: #export (SQL kind) + Text + + ## SQL + (template [<declaration> <kind>] + [(type: #export <declaration> (SQL <kind>))] + + [Literal (Value' Literal')] + [Column (Value' Column')] + [Placeholder (Value' Placeholder')] + [Value (Value' Any)] + + [Function Function'] + [Condition Condition'] + + [Index Index'] + + [Table Table'] + [View View'] + [Source Source'] + [DB DB'] + + [Order Order'] + + [(Schema kind) (Schema' kind)] + + [(Query where having order group limit offset) (Statement' (Action' where having (Query' order group limit offset)))] + [(Command where having) (Statement' (Action' where having Command'))] + [(Action where having kind) (Statement' (Action' where having kind))] + + [Definition (Statement' Definition')] + [Statement (Statement' Any)] + ) + + (def: Base-Query (.type (Query No-Where No-Having No-Order No-Group No-Limit No-Offset))) + (def: Any-Query (.type (Query Any Any Any Any Any Any))) + + (def: #export read + {#.doc (doc "Only use this function for debugging purposes." + "Do not use this function to actually execute SQL code.")} + (-> (SQL Any) Text) + (|>> :representation)) + + (def: #export (sql action) + (-> Statement Text) + (format (:representation action) ";")) + + (def: enumerate + (-> (List (SQL Any)) Text) + (|>> (list\map (|>> :representation)) + (text.join-with ", "))) + + ## Value + (def: #export ? Placeholder (:abstraction "?")) + + (def: literal + (-> Text Literal) + (|>> :abstraction)) + + (def: #export null Literal (..literal "NULL")) + + (def: #export (int value) + (-> Int Literal) + (..literal (if (i.< +0 value) + (%.int value) + (%.nat (.nat value))))) + + (def: #export function + (-> Text Function) + (|>> :abstraction)) + + (def: #export (call function parameters) + (-> Function (List Value) Value) + (:abstraction (format (:representation function) + (..parenthesize (..enumerate parameters))))) + + ## Condition + (template [<name> <sql-op>] + [(def: #export (<name> reference sample) + (-> Value Value Condition) + (:abstraction + (..parenthesize + (format (:representation sample) + " " <sql-op> " " + (:representation reference)))))] + + [= "="] + [<> "<>"] + [is? "IS"] + [> ">"] + [>= ">="] + [< "<"] + [<= "<="] + [like? "LIKE"] + [ilike? "ILIKE"] + ) + + (def: #export (between from to sample) + (-> Value Value Value Condition) + (:abstraction + (..parenthesize + (format (:representation sample) + " BETWEEN " (:representation from) + " AND " (:representation to))))) + + (def: #export (in options value) + (-> (List Value) Value Condition) + (:abstraction + (format (:representation value) + " IN " + (..parenthesize (enumerate options))))) + + (template [<func-name> <sql-op>] + [(def: #export (<func-name> left right) + (-> Condition Condition Condition) + (:abstraction + (format (..parenthesize (:representation left)) + " " <sql-op> " " + (..parenthesize (:representation right)))))] + + [and "AND"] + [or "OR"] + ) + + (template [<name> <type> <sql>] + [(def: #export <name> + (-> <type> Condition) + (|>> :representation ..parenthesize (format <sql> " ") :abstraction))] + + [not Condition "NOT"] + [exists Any-Query "EXISTS"] + ) + + ## Query + (template [<name> <type> <decoration>] + [(def: #export <name> + (-> <type> Source) + (|>> :representation <decoration> :abstraction))] + + [from-table Table (<|)] + [from-view View (<|)] + [from-query Any-Query ..parenthesize] + ) + + (template [<func-name> <op>] + [(def: #export (<func-name> columns source) + (-> (List [Column Alias]) Source Base-Query) + (:abstraction + (format <op> + " " + (case columns + #.Nil + "*" + + _ + (|> columns + (list\map (.function (_ [column alias]) + (if (text\= ..no-alias alias) + (:representation column) + (format (:representation column) " AS " alias)))) + (text.join-with ", "))) + " FROM " (:representation source))))] + + + [select "SELECT"] + [select-distinct "SELECT DISTINCT"] + ) + + (template [<name> <join-text>] + [(def: #export (<name> table condition prev) + (-> Table Condition Base-Query Base-Query) + (:abstraction + (format (:representation prev) + " " <join-text> " " + (:representation table) + " ON " (:representation condition))))] + + [inner-join "INNER JOIN"] + [left-join "LEFT JOIN"] + [right-join "RIGHT JOIN"] + [full-outer-join "FULL OUTER JOIN"] + ) + + (template [<function> <sql-op>] + [(def: #export (<function> left right) + (-> Any-Query Any-Query (Query Without-Where Without-Having No-Order No-Group No-Limit No-Offset)) + (:abstraction + (format (:representation left) + " " <sql-op> " " + (:representation right))))] + + [union "UNION"] + [union-all "UNION ALL"] + [intersect "INTERSECT"] + ) + + (template [<name> <sql> <variables> <input> <output>] + [(def: #export (<name> value query) + (All <variables> + (-> Nat <input> <output>)) + (:abstraction + (format (:representation query) + " " <sql> " " + (%.nat value))))] + + [limit "LIMIT" [where having order group offset] + (Query where having order group No-Limit offset) + (Query where having order group With-Limit offset)] + + [offset "OFFSET" [where having order group limit] + (Query where having order group limit No-Offset) + (Query where having order group limit With-Offset)] + ) + + (template [<name> <sql>] + [(def: #export <name> + Order + (:abstraction <sql>))] + + [ascending "ASC"] + [descending "DESC"] + ) + + (def: #export (order-by pairs query) + (All [where having group limit offset] + (-> (List [Value Order]) + (Query where having No-Order group limit offset) + (Query where having With-Order group limit offset))) + (case pairs + #.Nil + (|> query :representation :abstraction) + + _ + (:abstraction + (format (:representation query) + " ORDER BY " + (|> pairs + (list\map (.function (_ [value order]) + (format (:representation value) " " (:representation order)))) + (text.join-with ", ")))))) + + (def: #export (group-by pairs query) + (All [where having order limit offset] + (-> (List Value) + (Query where having order No-Group limit offset) + (Query where having order With-Group limit offset))) + (case pairs + #.Nil + (|> query :representation :abstraction) + + _ + (:abstraction + (format (:representation query) + " GROUP BY " + (..enumerate pairs))))) + + ## Command + (def: #export (insert table columns rows) + (-> Table (List Column) (List (List Value)) (Command Without-Where Without-Having)) + (:abstraction + (format "INSERT INTO " (:representation table) " " + (..parenthesize (..enumerate columns)) + " VALUES " + (|> rows + (list\map (|>> ..enumerate ..parenthesize)) + (text.join-with ", ")) + ))) + + (def: #export (update table pairs) + (-> Table (List [Column Value]) (Command No-Where No-Having)) + (:abstraction (format "UPDATE " (:representation table) + (case pairs + #.Nil + "" + + _ + (format " SET " (|> pairs + (list\map (.function (_ [column value]) + (format (:representation column) "=" (:representation value)))) + (text.join-with ", "))))))) + + (def: #export delete + (-> Table (Command No-Where No-Having)) + (|>> :representation (format "DELETE FROM ") :abstraction)) + + ## Action + (def: #export (where condition prev) + (All [kind having] + (-> Condition (Action No-Where having kind) (Action With-Where having kind))) + (:abstraction + (format (:representation prev) + " WHERE " + (:representation condition)))) + + (def: #export (having condition prev) + (All [where kind] + (-> Condition (Action where No-Having kind) (Action where With-Having kind))) + (:abstraction + (format (:representation prev) + " HAVING " + (:representation condition)))) + + ## Schema + (def: #export type + (-> Text (Schema Value)) + (|>> :abstraction)) + + (template [<name> <attr>] + [(def: #export (<name> attr) + (-> (Schema Value) (Schema Value)) + (:abstraction + (format (:representation attr) " " <attr>)))] + + [unique "UNIQUE"] + [not-null "NOT NULL"] + [stored "STORED"] + ) + + (def: #export (default value attr) + (-> Value (Schema Value) (Schema Value)) + (:abstraction + (format (:representation attr) " DEFAULT " (:representation value)))) + + (def: #export (define-column name type) + (-> Column (Schema Value) (Schema Column)) + (:abstraction + (format (:representation name) " " (:representation type)))) + + (def: #export (auto-increment offset column) + (-> Int (Schema Column) (Schema Column)) + (:abstraction + (format (:representation column) " AUTO_INCREMENT=" (:representation (..int offset))))) + + (def: #export (create-table or-replace? table columns) + (-> Bit Table (List (Schema Column)) Definition) + (let [command (if or-replace? + "CREATE OR REPLACE TABLE" + "CREATE TABLE IF NOT EXISTS")] + (:abstraction + (format command " " (:representation table) + (..parenthesize (..enumerate columns)))))) + + (def: #export (create-table-as table query) + (-> Table Any-Query Definition) + (:abstraction + (format "CREATE TABLE " (:representation table) " AS " (:representation query)))) + + (template [<name> <sql>] + [(def: #export (<name> table) + (-> Table Definition) + (:abstraction + (format <sql> " TABLE " (:representation table))))] + + [drop "DROP"] + [truncate "TRUNCATE"] + ) + + (def: #export (add-column table column) + (-> Table (Schema Column) Definition) + (:abstraction + (format "ALTER TABLE " (:representation table) " ADD " (:representation column)))) + + (def: #export (drop-column table column) + (-> Table Column Definition) + (:abstraction + (format "ALTER TABLE " (:representation table) " DROP COLUMN " (:representation column)))) + + (template [<name> <type>] + [(def: #export (<name> name) + (-> Text <type>) + (:abstraction name))] + + [column Column] + [table Table] + [view View] + [index Index] + [db DB] + ) + + (template [<name> <type> <sql>] + [(def: #export <name> + (-> <type> Definition) + (|>> :representation (format <sql> " ") :abstraction))] + + [create-db DB "CREATE DATABASE"] + [drop-db DB "DROP DATABASE"] + [drop-view View "DROP VIEW"] + ) + + (template [<name> <sql>] + [(def: #export (<name> view query) + (-> View Any-Query Definition) + (:abstraction + (format <sql> " " (:representation view) " AS " (:representation query))))] + + [create-view "CREATE VIEW"] + [create-or-replace-view "CREATE OR REPLACE VIEW"] + ) + + (def: #export (create-index index table unique? columns) + (-> Index Table Bit (List Column) Definition) + (:abstraction + (format "CREATE " (if unique? "UNIQUE" "") " INDEX " (:representation index) + " ON " (:representation table) " " (..parenthesize (..enumerate columns))))) + + (def: #export (with alias query body) + (All [where having order group limit offset] + (-> Table Any-Query + (Query where having order group limit offset) + (Query where having order group limit offset))) + (:abstraction + (format "WITH " (:representation alias) + " AS " (..parenthesize (:representation query)) + " " (:representation body)))) + ) diff --git a/stdlib/source/library/lux/world/file.lux b/stdlib/source/library/lux/world/file.lux new file mode 100644 index 000000000..7f95b3282 --- /dev/null +++ b/stdlib/source/library/lux/world/file.lux @@ -0,0 +1,1303 @@ +(.module: + [library + [lux #* + ["@" target] + ["." ffi] + [abstract + ["." monad (#+ Monad do)]] + [control + [pipe (#+ case>)] + ["." try (#+ Try) ("#\." functor)] + ["." exception (#+ exception:)] + ["." io (#+ IO) ("#\." functor)] + ["." function] + [concurrency + ["." promise (#+ Promise)] + ["." stm (#+ Var STM)]]] + [data + ["." bit ("#\." equivalence)] + ["." product] + ["." maybe ("#\." functor)] + ["." binary (#+ Binary)] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." array (#+ Array)] + ["." list ("#\." functor)] + ["." dictionary (#+ Dictionary)]]] + [macro + ["." template]] + [math + [number + ["i" int] + ["f" frac]]] + [time + ["." instant (#+ Instant)] + ["." duration]]]]) + +(type: #export Path + Text) + +(`` (interface: #export (System !) + (: Text + separator) + + (~~ (template [<name> <output>] + [(: (-> Path (! <output>)) + <name>)] + + [file? Bit] + [directory? Bit] + )) + + (~~ (template [<name> <output>] + [(: (-> Path (! (Try <output>))) + <name>)] + + [make_directory Any] + [directory_files (List Path)] + [sub_directories (List Path)] + + [file_size Nat] + [last_modified Instant] + [can_execute? Bit] + [read Binary] + [delete Any] + )) + + (~~ (template [<name> <input>] + [(: (-> <input> Path (! (Try Any))) + <name>)] + + [modify Instant] + [write Binary] + [append Binary] + [move Path] + )) + )) + +(def: #export (un_nest fs path) + (All [!] (-> (System !) Path (Maybe [Path Text]))) + (let [/ (\ fs separator)] + (case (text.last_index_of / path) + #.None + #.None + + (#.Some last_separator) + (do maybe.monad + [[parent temp] (text.split last_separator path) + [_ child] (text.split (text.size /) temp)] + (wrap [parent child]))))) + +(def: #export (parent fs path) + (All [!] (-> (System !) Path (Maybe Path))) + (|> (..un_nest fs path) + (maybe\map product.left))) + +(def: #export (name fs path) + (All [!] (-> (System !) Path Text)) + (|> (..un_nest fs path) + (maybe\map product.right) + (maybe.default path))) + +(def: #export (async fs) + (-> (System IO) (System Promise)) + (`` (implementation + (def: separator + (\ fs separator)) + + (~~ (template [<name>] + [(def: <name> + (|>> (\ fs <name>) + promise.future))] + + [file?] + [directory?] + + [make_directory] + [directory_files] + [sub_directories] + + [file_size] + [last_modified] + [can_execute?] + [read] + [delete])) + + (~~ (template [<name>] + [(def: (<name> input path) + (promise.future (\ fs <name> input path)))] + + [modify] + [write] + [append] + [move])) + ))) + +(def: #export (nest fs parent child) + (All [!] (-> (System !) Path Text Path)) + (format parent (\ fs separator) child)) + +(template [<name>] + [(exception: #export (<name> {file Path}) + (exception.report + ["Path" file]))] + + [cannot_make_file] + [cannot_find_file] + [cannot_delete] + + [cannot_make_directory] + [cannot_find_directory] + + [cannot_read_all_data] + ) + +(with_expansions [<extra> (as_is (exception: #export (cannot_move {target Path} {source Path}) + (exception.report + ["Source" source] + ["Target" target])))] + (for {@.old (as_is <extra>) + @.jvm (as_is <extra>) + @.lua (as_is <extra>)} + (as_is))) + +(with_expansions [<for_jvm> (as_is (exception: #export (cannot_modify_file {instant Instant} {file Path}) + (exception.report + ["Instant" (%.instant instant)] + ["Path" file])) + + (ffi.import: java/lang/String) + + (`` (ffi.import: java/io/File + ["#::." + (new [java/lang/String]) + (~~ (template [<name>] + [(<name> [] #io #try boolean)] + + [createNewFile] [mkdir] + [delete] + [isFile] [isDirectory] + [canRead] [canWrite] [canExecute])) + + (length [] #io #try long) + (listFiles [] #io #try #? [java/io/File]) + (getAbsolutePath [] #io #try java/lang/String) + (renameTo [java/io/File] #io #try boolean) + (lastModified [] #io #try long) + (setLastModified [long] #io #try boolean) + (#static separator java/lang/String)])) + + (ffi.import: java/lang/AutoCloseable + ["#::." + (close [] #io #try void)]) + + (ffi.import: java/io/OutputStream + ["#::." + (write [[byte]] #io #try void) + (flush [] #io #try void)]) + + (ffi.import: java/io/FileOutputStream + ["#::." + (new [java/io/File boolean] #io #try)]) + + (ffi.import: java/io/InputStream + ["#::." + (read [[byte]] #io #try int)]) + + (ffi.import: java/io/FileInputStream + ["#::." + (new [java/io/File] #io #try)]) + + (`` (implementation: #export default + (System IO) + + (def: separator + (java/io/File::separator)) + + (~~ (template [<name> <method>] + [(def: <name> + (|>> java/io/File::new + <method> + (io\map (|>> (try.default false)))))] + + [file? java/io/File::isFile] + [directory? java/io/File::isDirectory] + )) + + (def: (make_directory path) + (|> path + java/io/File::new + java/io/File::mkdir)) + + (~~ (template [<name> <method>] + [(def: (<name> path) + (do {! (try.with io.monad)} + [?children (java/io/File::listFiles (java/io/File::new path))] + (case ?children + (#.Some children) + (|> children + array.to_list + (monad.filter ! (|>> <method>)) + (\ ! map (monad.map ! (|>> java/io/File::getAbsolutePath))) + (\ ! join)) + + #.None + (\ io.monad wrap (exception.throw ..cannot_find_directory [path])))))] + + [directory_files java/io/File::isFile] + [sub_directories java/io/File::isDirectory] + )) + + (def: file_size + (|>> java/io/File::new + java/io/File::length + (\ (try.with io.monad) map .nat))) + + (def: last_modified + (|>> java/io/File::new + (java/io/File::lastModified) + (\ (try.with io.monad) map (|>> duration.from_millis instant.absolute)))) + + (def: can_execute? + (|>> java/io/File::new + java/io/File::canExecute)) + + (def: (read path) + (do (try.with io.monad) + [#let [file (java/io/File::new path)] + size (java/io/File::length file) + #let [data (binary.create (.nat size))] + stream (java/io/FileInputStream::new file) + bytes_read (java/io/InputStream::read data stream) + _ (java/lang/AutoCloseable::close stream)] + (if (i.= size bytes_read) + (wrap data) + (\ io.monad wrap (exception.throw ..cannot_read_all_data path))))) + + (def: (delete path) + (|> path + java/io/File::new + java/io/File::delete)) + + (def: (modify time_stamp path) + (|> path + java/io/File::new + (java/io/File::setLastModified (|> time_stamp instant.relative duration.to_millis)))) + + (~~ (template [<name> <flag>] + [(def: (<name> data path) + (do (try.with io.monad) + [stream (java/io/FileOutputStream::new (java/io/File::new path) <flag>) + _ (java/io/OutputStream::write data stream) + _ (java/io/OutputStream::flush stream)] + (java/lang/AutoCloseable::close stream)))] + + [write #0] + [append #1] + )) + + (def: (move destination origin) + (|> origin + java/io/File::new + (java/io/File::renameTo (java/io/File::new destination)))) + )))] + (for {@.old (as_is <for_jvm>) + @.jvm (as_is <for_jvm>) + + @.js + (as_is (ffi.import: Buffer + ["#::." + (#static from [Binary] ..Buffer)]) + + (ffi.import: FileDescriptor) + + (ffi.import: Stats + ["#::." + (size ffi.Number) + (mtimeMs ffi.Number) + (isFile [] #io #try ffi.Boolean) + (isDirectory [] #io #try ffi.Boolean)]) + + (ffi.import: FsConstants + ["#::." + (F_OK ffi.Number) + (R_OK ffi.Number) + (W_OK ffi.Number) + (X_OK ffi.Number)]) + + (ffi.import: Fs + ["#::." + (constants FsConstants) + (readFileSync [ffi.String] #io #try Binary) + (appendFileSync [ffi.String Buffer] #io #try Any) + (writeFileSync [ffi.String Buffer] #io #try Any) + (statSync [ffi.String] #io #try Stats) + (accessSync [ffi.String ffi.Number] #io #try Any) + (renameSync [ffi.String ffi.String] #io #try Any) + (utimesSync [ffi.String ffi.Number ffi.Number] #io #try Any) + (unlink [ffi.String] #io #try Any) + (readdirSync [ffi.String] #io #try (Array ffi.String)) + (mkdirSync [ffi.String] #io #try Any) + (rmdirSync [ffi.String] #io #try Any)]) + + (ffi.import: JsPath + ["#::." + (sep ffi.String)]) + + (template [<name> <path>] + [(def: (<name> _) + (-> [] (Maybe (-> ffi.String Any))) + (ffi.constant (-> ffi.String Any) <path>))] + + [normal_require [require]] + [global_require [global require]] + [process_load [global process mainModule constructor _load]] + ) + + (def: (require _) + (-> [] (-> ffi.String Any)) + (case [(normal_require []) (global_require []) (process_load [])] + (^or [(#.Some require) _ _] + [_ (#.Some require) _] + [_ _ (#.Some require)]) + require + + _ + (undefined))) + + (template [<name> <module> <type>] + [(def: (<name> _) + (-> [] <type>) + (:as <type> (..require [] <module>)))] + + [node_fs "fs" ..Fs] + [node_path "path" ..JsPath] + ) + + (`` (implementation: #export default + (System IO) + + (def: separator + (if ffi.on_node_js? + (JsPath::sep (..node_path [])) + "/")) + + (~~ (template [<name> <method>] + [(def: (<name> path) + (do {! io.monad} + [?stats (Fs::statSync [path] (..node_fs []))] + (case ?stats + (#try.Success stats) + (|> stats + (<method> []) + (\ ! map (|>> (try.default false)))) + + (#try.Failure _) + (wrap false))))] + + [file? Stats::isFile] + [directory? Stats::isDirectory] + )) + + (def: (make_directory path) + (let [node_fs (..node_fs [])] + (do io.monad + [outcome (Fs::accessSync [path (|> node_fs Fs::constants FsConstants::F_OK)] node_fs)] + (case outcome + (#try.Success _) + (wrap (exception.throw ..cannot_make_directory [path])) + + (#try.Failure _) + (Fs::mkdirSync [path] node_fs))))) + + (~~ (template [<name> <method>] + [(def: (<name> path) + (do {! (try.with io.monad)} + [#let [node_fs (..node_fs [])] + subs (Fs::readdirSync [path] node_fs)] + (|> subs + array.to_list + (monad.map ! (function (_ sub) + (do ! + [stats (Fs::statSync [sub] node_fs)] + (\ ! map (|>> [sub]) (<method> [] stats))))) + (\ ! map (|>> (list.filter product.right) + (list\map product.left))))))] + + [directory_files Stats::isFile] + [sub_directories Stats::isDirectory] + )) + + (def: (file_size path) + (let [! (try.with io.monad)] + (|> (..node_fs []) + (Fs::statSync [path]) + (\ ! map (|>> Stats::size + f.nat))))) + + (def: (last_modified path) + (let [! (try.with io.monad)] + (|> (..node_fs []) + (Fs::statSync [path]) + (\ ! map (|>> Stats::mtimeMs + f.int + duration.from_millis + instant.absolute))))) + + (def: (can_execute? path) + (let [node_fs (..node_fs [])] + (|> node_fs + (Fs::accessSync [path (|> node_fs Fs::constants FsConstants::X_OK)]) + (io\map (|>> (case> (#try.Success _) + true + + (#try.Failure _) + false) + #try.Success))))) + + (def: (read path) + (Fs::readFileSync [path] (..node_fs []))) + + (def: (delete path) + (do {! (try.with io.monad)} + [#let [node_fs (..node_fs [])] + stats (Fs::statSync [path] node_fs) + verdict (Stats::isFile [] stats)] + (if verdict + (Fs::unlink [path] node_fs) + (Fs::rmdirSync [path] node_fs)))) + + (def: (modify time_stamp path) + (let [when (|> time_stamp instant.relative duration.to_millis i.frac)] + (Fs::utimesSync [path when when] (..node_fs [])))) + + (~~ (template [<name> <method>] + [(def: (<name> data path) + (<method> [path (Buffer::from data)] (..node_fs [])))] + + [write Fs::writeFileSync] + [append Fs::appendFileSync] + )) + + (def: (move destination origin) + (Fs::renameSync [origin destination] (..node_fs []))) + ))) + + @.python + (as_is (type: (Tuple/2 left right) + (primitive "python_tuple[2]" [left right])) + + (ffi.import: PyFile + ["#::." + (read [] #io #try Binary) + (write [Binary] #io #try #? Any) + (close [] #io #try #? Any)]) + + (ffi.import: (open [ffi.String ffi.String] #io #try PyFile)) + (ffi.import: (tuple [[ffi.Integer ffi.Integer]] (Tuple/2 ffi.Integer ffi.Integer))) + + (ffi.import: os + ["#::." + (#static F_OK ffi.Integer) + (#static R_OK ffi.Integer) + (#static W_OK ffi.Integer) + (#static X_OK ffi.Integer) + + (#static mkdir [ffi.String] #io #try #? Any) + (#static access [ffi.String ffi.Integer] #io #try ffi.Boolean) + (#static remove [ffi.String] #io #try #? Any) + (#static rmdir [ffi.String] #io #try #? Any) + (#static rename [ffi.String ffi.String] #io #try #? Any) + (#static utime [ffi.String (Tuple/2 ffi.Integer ffi.Integer)] #io #try #? Any) + (#static listdir [ffi.String] #io #try (Array ffi.String))]) + + (ffi.import: os/path + ["#::." + (#static isfile [ffi.String] #io #try ffi.Boolean) + (#static isdir [ffi.String] #io #try ffi.Boolean) + (#static sep ffi.String) + (#static getsize [ffi.String] #io #try ffi.Integer) + (#static getmtime [ffi.String] #io #try ffi.Float)]) + + (`` (implementation: #export default + (System IO) + + (def: separator + (os/path::sep)) + + (~~ (template [<name> <method>] + [(def: <name> + (|>> <method> + (io\map (|>> (try.default false)))))] + + [file? os/path::isfile] + [directory? os/path::isdir] + )) + + (def: make_directory + os::mkdir) + + (~~ (template [<name> <method>] + [(def: <name> + (let [! (try.with io.monad)] + (|>> os::listdir + (\ ! map (|>> array.to_list + (monad.map ! (function (_ sub) + (\ ! map (|>> [sub]) (<method> [sub])))) + (\ ! map (|>> (list.filter product.right) + (list\map product.left))))) + (\ ! join))))] + + [directory_files os/path::isfile] + [sub_directories os/path::isdir] + )) + + (def: file_size + (|>> os/path::getsize + (\ (try.with io.monad) map .nat))) + + (def: last_modified + (|>> os/path::getmtime + (\ (try.with io.monad) map (|>> f.int + (i.* +1,000) + duration.from_millis + instant.absolute)))) + + (def: (can_execute? path) + (os::access [path (os::X_OK)])) + + (def: (read path) + (do (try.with io.monad) + [file (..open [path "rb"]) + data (PyFile::read [] file) + _ (PyFile::close [] file)] + (wrap data))) + + (def: (delete path) + (do (try.with io.monad) + [? (os/path::isfile [path])] + (if ? + (os::remove [path]) + (os::rmdir [path])))) + + (def: (modify time_stamp path) + (let [when (|> time_stamp instant.relative duration.to_millis (i./ +1,000))] + (os::utime [path (..tuple [when when])]))) + + (~~ (template [<name> <mode>] + [(def: (<name> data path) + (do (try.with io.monad) + [file (..open [path <mode>]) + _ (PyFile::write [data] file)] + (PyFile::close [] file)))] + + [write "w+b"] + [append "ab"] + )) + + (def: (move destination origin) + (os::rename [origin destination])) + ))) + + @.ruby + (as_is (ffi.import: Time #as RubyTime + ["#::." + (#static at [Frac] RubyTime) + (to_f [] Frac)]) + + (ffi.import: Stat #as RubyStat + ["#::." + (executable? [] Bit) + (size Int) + (mtime [] RubyTime)]) + + (ffi.import: File #as RubyFile + ["#::." + (#static SEPARATOR ffi.String) + (#static open [Path ffi.String] #io #try RubyFile) + (#static stat [Path] #io #try RubyStat) + (#static delete [Path] #io #try Int) + (#static file? [Path] #io #try Bit) + (#static directory? [Path] #io #try Bit) + (#static utime [RubyTime RubyTime Path] #io #try Int) + + (read [] #io #try Binary) + (write [Binary] #io #try Int) + (flush [] #io #try #? Any) + (close [] #io #try #? Any)]) + + (ffi.import: Dir #as RubyDir + ["#::." + (#static open [Path] #io #try RubyDir) + + (children [] #io #try (Array Path)) + (close [] #io #try #? Any)]) + + (ffi.import: "fileutils" FileUtils #as RubyFileUtils + ["#::." + (#static move [Path Path] #io #try #? Any) + (#static rmdir [Path] #io #try #? Any) + (#static mkdir [Path] #io #try #? Any)]) + + (def: ruby_separator + Text + (..RubyFile::SEPARATOR)) + + (`` (implementation: #export default + (System IO) + + (def: separator + ..ruby_separator) + + (~~ (template [<name> <test>] + [(def: <name> + (|>> <test> + (io\map (|>> (try.default false)))))] + + [file? RubyFile::file?] + [directory? RubyFile::directory?] + )) + + (def: make_directory + RubyFileUtils::mkdir) + + (~~ (template [<name> <test>] + [(def: (<name> path) + (do {! (try.with io.monad)} + [self (RubyDir::open [path]) + children (RubyDir::children [] self) + output (loop [input (|> children + array.to_list + (list\map (|>> (format path ..ruby_separator)))) + output (: (List ..Path) + (list))] + (case input + #.Nil + (wrap output) + + (#.Cons head tail) + (do ! + [verdict (<test> head)] + (recur tail (if verdict + (#.Cons head output) + output))))) + _ (RubyDir::close [] self)] + (wrap output)))] + + [directory_files RubyFile::file?] + [sub_directories RubyFile::directory?] + )) + + (~~ (template [<name> <pipeline>] + [(def: <name> + (let [! (try.with io.monad)] + (|>> RubyFile::stat + (\ ! map (`` (|>> (~~ (template.splice <pipeline>))))))))] + + [file_size [RubyStat::size .nat]] + [last_modified [(RubyStat::mtime []) + (RubyTime::to_f []) + (f.* +1,000.0) + f.int + duration.from_millis + instant.absolute]] + [can_execute? [(RubyStat::executable? [])]] + )) + + (def: (read path) + (do (try.with io.monad) + [file (RubyFile::open [path "rb"]) + data (RubyFile::read [] file) + _ (RubyFile::close [] file)] + (wrap data))) + + (def: (delete path) + (do (try.with io.monad) + [? (RubyFile::file? path)] + (if ? + (RubyFile::delete [path]) + (RubyFileUtils::rmdir [path])))) + + (def: (modify moment path) + (let [moment (|> moment + instant.relative + duration.to_millis + i.frac + (f./ +1,000.0) + RubyTime::at)] + (RubyFile::utime [moment moment path]))) + + (~~ (template [<mode> <name>] + [(def: (<name> data path) + (do {! (try.with io.monad)} + [file (RubyFile::open [path <mode>]) + data (RubyFile::write [data] file) + _ (RubyFile::flush [] file) + _ (RubyFile::close [] file)] + (wrap [])))] + + ["wb" write] + ["ab" append] + )) + + (def: (move destination origin) + (do (try.with io.monad) + [_ (RubyFileUtils::move [origin destination])] + (wrap []))) + ))) + + ## @.php + ## (as_is (ffi.import: (FILE_APPEND Int)) + ## ## https://www.php.net/manual/en/dir.constants.php + ## (ffi.import: (DIRECTORY_SEPARATOR ffi.String)) + ## ## https://www.php.net/manual/en/function.pack.php + ## ## https://www.php.net/manual/en/function.unpack.php + ## (ffi.import: (unpack [ffi.String ffi.String] Binary)) + ## ## https://www.php.net/manual/en/ref.filesystem.php + ## ## https://www.php.net/manual/en/function.file-get-contents.php + ## (ffi.import: (file_get_contents [Path] #io #try ffi.String)) + ## ## https://www.php.net/manual/en/function.file-put-contents.php + ## (ffi.import: (file_put_contents [Path ffi.String Int] #io #try ffi.Integer)) + ## (ffi.import: (filemtime [Path] #io #try ffi.Integer)) + ## (ffi.import: (filesize [Path] #io #try ffi.Integer)) + ## (ffi.import: (is_executable [Path] #io #try ffi.Boolean)) + ## (ffi.import: (touch [Path ffi.Integer] #io #try ffi.Boolean)) + ## (ffi.import: (rename [Path Path] #io #try ffi.Boolean)) + ## (ffi.import: (unlink [Path] #io #try ffi.Boolean)) + + ## ## https://www.php.net/manual/en/function.rmdir.php + ## (ffi.import: (rmdir [Path] #io #try ffi.Boolean)) + ## ## https://www.php.net/manual/en/function.scandir.php + ## (ffi.import: (scandir [Path] #io #try (Array Path))) + ## ## https://www.php.net/manual/en/function.is-file.php + ## (ffi.import: (is_file [Path] #io #try ffi.Boolean)) + ## ## https://www.php.net/manual/en/function.is-dir.php + ## (ffi.import: (is_dir [Path] #io #try ffi.Boolean)) + ## ## https://www.php.net/manual/en/function.mkdir.php + ## (ffi.import: (mkdir [Path] #io #try ffi.Boolean)) + + ## (def: byte_array_format "C*") + ## (def: default_separator (..DIRECTORY_SEPARATOR)) + + ## (template [<name>] + ## [(exception: #export (<name> {file Path}) + ## (exception.report + ## ["Path" file]))] + + ## [cannot_write_to_file] + ## ) + + ## (`` (implementation: (file path) + ## (-> Path (File IO)) + + ## (~~ (template [<name> <mode>] + ## [(def: (<name> data) + ## (do {! (try.with io.monad)} + ## [outcome (..file_put_contents [path ("php pack" ..byte_array_format data) <mode>])] + ## (if (bit\= false (:as Bit outcome)) + ## (\ io.monad wrap (exception.throw ..cannot_write_to_file [path])) + ## (wrap []))))] + + ## [over_write +0] + ## [append (..FILE_APPEND)] + ## )) + + ## (def: (content _) + ## (do {! (try.with io.monad)} + ## [data (..file_get_contents [path])] + ## (if (bit\= false (:as Bit data)) + ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) + ## (wrap (..unpack [..byte_array_format data]))))) + + ## (def: path + ## path) + + ## (~~ (template [<name> <ffi> <pipeline>] + ## [(def: (<name> _) + ## (do {! (try.with io.monad)} + ## [value (<ffi> [path])] + ## (if (bit\= false (:as Bit value)) + ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) + ## (wrap (`` (|> value (~~ (template.splice <pipeline>))))))))] + + ## [size ..filesize [.nat]] + ## [last_modified ..filemtime [(i.* +1,000) duration.from_millis instant.absolute]] + ## )) + + ## (def: (can_execute? _) + ## (..is_executable [path])) + + ## (def: (modify moment) + ## (do {! (try.with io.monad)} + ## [verdict (..touch [path (|> moment instant.relative duration.to_millis (i./ +1,000))])] + ## (if (bit\= false (:as Bit verdict)) + ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) + ## (wrap [])))) + + ## (def: (move destination) + ## (do {! (try.with io.monad)} + ## [verdict (..rename [path destination])] + ## (if (bit\= false (:as Bit verdict)) + ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) + ## (wrap (file destination))))) + + ## (def: (delete _) + ## (do (try.with io.monad) + ## [verdict (..unlink [path])] + ## (if (bit\= false (:as Bit verdict)) + ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) + ## (wrap [])))) + ## )) + + ## (`` (implementation: (directory path) + ## (-> Path (Directory IO)) + + ## (def: scope + ## path) + + ## (~~ (template [<name> <test> <constructor> <capability>] + ## [(def: (<name> _) + ## (do {! (try.with io.monad)} + ## [children (..scandir [path])] + ## (loop [input (|> children + ## array.to_list + ## (list.filter (function (_ child) + ## (not (or (text\= "." child) + ## (text\= ".." child)))))) + ## output (: (List (<capability> IO)) + ## (list))] + ## (case input + ## #.Nil + ## (wrap output) + + ## (#.Cons head tail) + ## (do ! + ## [verdict (<test> head)] + ## (if verdict + ## (recur tail (#.Cons (<constructor> head) output)) + ## (recur tail output)))))))] + + ## [files ..is_file ..file File] + ## [directories ..is_dir directory Directory] + ## )) + + ## (def: (discard _) + ## (do (try.with io.monad) + ## [verdict (..rmdir [path])] + ## (if (bit\= false (:as Bit verdict)) + ## (\ io.monad wrap (exception.throw ..cannot_find_directory [path])) + ## (wrap [])))) + ## )) + + ## (`` (implementation: #export default + ## (System IO) + + ## (~~ (template [<name> <test> <constructor> <exception>] + ## [(def: (<name> path) + ## (do {! (try.with io.monad)} + ## [verdict (<test> path)] + ## (\ io.monad wrap + ## (if verdict + ## (#try.Success (<constructor> path)) + ## (exception.throw <exception> [path])))))] + + ## [file ..is_file ..file ..cannot_find_file] + ## [directory ..is_dir ..directory ..cannot_find_directory] + ## )) + + ## (def: (make_file path) + ## (do {! (try.with io.monad)} + ## [verdict (..touch [path (|> instant.now io.run instant.relative duration.to_millis (i./ +1,000))])] + ## (\ io.monad wrap + ## (if verdict + ## (#try.Success (..file path)) + ## (exception.throw ..cannot_make_file [path]))))) + + ## (def: (make_directory path) + ## (do {! (try.with io.monad)} + ## [verdict (..mkdir path)] + ## (\ io.monad wrap + ## (if verdict + ## (#try.Success (..directory path)) + ## (exception.throw ..cannot_make_directory [path]))))) + + ## (def: separator + ## ..default_separator) + ## )) + ## ) + } + (as_is))) + +(def: #export (exists? monad fs path) + (All [!] (-> (Monad !) (System !) Path (! Bit))) + (do monad + [verdict (\ fs file? path)] + (if verdict + (wrap verdict) + (\ fs directory? path)))) + +(type: Mock_File + {#mock_last_modified Instant + #mock_can_execute Bit + #mock_content Binary}) + +(type: #rec Mock + (Dictionary Text (Either Mock_File Mock))) + +(def: empty_mock + Mock + (dictionary.new text.hash)) + +(def: (retrieve_mock_file! separator path mock) + (-> Text Path Mock (Try [Text Mock_File])) + (loop [directory mock + trail (text.split_all_with separator path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (exception.throw ..cannot_find_file [path]) + + (#.Some node) + (case [node tail] + [(#.Left file) #.Nil] + (#try.Success [head file]) + + [(#.Right sub_directory) (#.Cons _)] + (recur sub_directory tail) + + _ + (exception.throw ..cannot_find_file [path]))) + + #.Nil + (exception.throw ..cannot_find_file [path])))) + +(def: (update_mock_file! / path now content mock) + (-> Text Path Instant Binary Mock (Try Mock)) + (loop [directory mock + trail (text.split_all_with / path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (case tail + #.Nil + (#try.Success (dictionary.put head + (#.Left {#mock_last_modified now + #mock_can_execute false + #mock_content content}) + directory)) + + (#.Cons _) + (exception.throw ..cannot_find_file [path])) + + (#.Some node) + (case [node tail] + [(#.Left file) #.Nil] + (#try.Success (dictionary.put head + (#.Left (|> file + (set@ #mock_last_modified now) + (set@ #mock_content content))) + directory)) + + [(#.Right sub_directory) (#.Cons _)] + (do try.monad + [sub_directory (recur sub_directory tail)] + (wrap (dictionary.put head (#.Right sub_directory) directory))) + + _ + (exception.throw ..cannot_find_file [path]))) + + #.Nil + (exception.throw ..cannot_find_file [path])))) + +(def: (mock_delete! / path mock) + (-> Text Path Mock (Try Mock)) + (loop [directory mock + trail (text.split_all_with / path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (exception.throw ..cannot_delete [path]) + + (#.Some node) + (case tail + #.Nil + (case node + (#.Left file) + (#try.Success (dictionary.remove head directory)) + + (#.Right sub_directory) + (if (dictionary.empty? sub_directory) + (#try.Success (dictionary.remove head directory)) + (exception.throw ..cannot_delete [path]))) + + (#.Cons _) + (case node + (#.Left file) + (exception.throw ..cannot_delete [path]) + + (#.Right sub_directory) + (do try.monad + [sub_directory' (recur sub_directory tail)] + (wrap (dictionary.put head (#.Right sub_directory') directory)))))) + + #.Nil + (exception.throw ..cannot_delete [path])))) + +(def: (try_update! transform var) + (All [a] (-> (-> a (Try a)) (Var a) (STM (Try Any)))) + (do {! stm.monad} + [|var| (stm.read var)] + (case (transform |var|) + (#try.Success |var|) + (do ! + [_ (stm.write |var| var)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error))))) + +(def: (make_mock_directory! / path mock) + (-> Text Path Mock (Try Mock)) + (loop [directory mock + trail (text.split_all_with / path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (case tail + #.Nil + (#try.Success (dictionary.put head (#.Right ..empty_mock) directory)) + + (#.Cons _) + (exception.throw ..cannot_make_directory [path])) + + (#.Some node) + (case [node tail] + [(#.Right sub_directory) (#.Cons _)] + (do try.monad + [sub_directory (recur sub_directory tail)] + (wrap (dictionary.put head (#.Right sub_directory) directory))) + + _ + (exception.throw ..cannot_make_directory [path]))) + + #.Nil + (exception.throw ..cannot_make_directory [path])))) + +(def: (retrieve_mock_directory! / path mock) + (-> Text Path Mock (Try Mock)) + (loop [directory mock + trail (text.split_all_with / path)] + (case trail + #.Nil + (#try.Success directory) + + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (exception.throw ..cannot_find_directory [path]) + + (#.Some node) + (case node + (#.Left _) + (exception.throw ..cannot_find_directory [path]) + + (#.Right sub_directory) + (case tail + #.Nil + (#try.Success sub_directory) + + (#.Cons _) + (recur sub_directory tail))))))) + +(def: #export (mock separator) + (-> Text (System Promise)) + (let [store (stm.var ..empty_mock)] + (`` (implementation + (def: separator + separator) + + (~~ (template [<method> <retrieve>] + [(def: (<method> path) + (|> store + stm.read + (\ stm.monad map + (|>> (<retrieve> separator path) + (try\map (function.constant true)) + (try.default false))) + stm.commit))] + + [file? ..retrieve_mock_file!] + [directory? ..retrieve_mock_directory!])) + + (def: (make_directory path) + (stm.commit + (do {! stm.monad} + [|store| (stm.read store)] + (case (..make_mock_directory! separator path |store|) + (#try.Success |store|) + (do ! + [_ (stm.write |store| store)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error)))))) + + (~~ (template [<method> <tag>] + [(def: (<method> path) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (do try.monad + [directory (..retrieve_mock_directory! separator path |store|)] + (wrap (|> directory + dictionary.entries + (list.all (function (_ [node_name node]) + (case node + (<tag> _) + (#.Some (format path separator node_name)) + + _ + #.None))))))))))] + + [directory_files #.Left] + [sub_directories #.Right] + )) + + (def: (file_size path) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (|> |store| + (..retrieve_mock_file! separator path) + (try\map (|>> product.right + (get@ #mock_content) + binary.size))))))) + + (def: (last_modified path) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (|> |store| + (..retrieve_mock_file! separator path) + (try\map (|>> product.right + (get@ #mock_last_modified)))))))) + + (def: (can_execute? path) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (|> |store| + (..retrieve_mock_file! separator path) + (try\map (|>> product.right + (get@ #mock_can_execute)))))))) + + (def: (read path) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (|> |store| + (..retrieve_mock_file! separator path) + (try\map (|>> product.right + (get@ #mock_content)))))))) + + (def: (delete path) + (stm.commit + (..try_update! (..mock_delete! separator path) store))) + + (def: (modify now path) + (stm.commit + (..try_update! (function (_ |store|) + (do try.monad + [[name file] (..retrieve_mock_file! separator path |store|)] + (..update_mock_file! separator path now (get@ #mock_content file) |store|))) + store))) + + (def: (write content path) + (do promise.monad + [now (promise.future instant.now)] + (stm.commit + (..try_update! (..update_mock_file! separator path now content) store)))) + + (def: (append content path) + (do promise.monad + [now (promise.future instant.now)] + (stm.commit + (..try_update! (function (_ |store|) + (do try.monad + [[name file] (..retrieve_mock_file! separator path |store|)] + (..update_mock_file! separator path now + (\ binary.monoid compose + (get@ #mock_content file) + content) + |store|))) + store)))) + + (def: (move destination origin) + (stm.commit + (do {! stm.monad} + [|store| (stm.read store)] + (case (do try.monad + [[name file] (..retrieve_mock_file! separator origin |store|) + |store| (..mock_delete! separator origin |store|)] + (..update_mock_file! separator destination (get@ #mock_last_modified file) (get@ #mock_content file) |store|)) + (#try.Success |store|) + (do ! + [_ (stm.write |store| store)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error)))))) + )))) + +(def: (check_or_make_directory monad fs path) + (All [!] (-> (Monad !) (System !) Path (! (Try Any)))) + (do monad + [? (\ fs directory? path)] + (if ? + (wrap (#try.Success [])) + (\ fs make_directory path)))) + +(def: #export (make_directories monad fs path) + (All [!] (-> (Monad !) (System !) Path (! (Try Any)))) + (let [rooted? (text.starts_with? (\ fs separator) path) + segments (text.split_all_with (\ fs separator) path)] + (case (if rooted? + (list.drop 1 segments) + segments) + #.Nil + (\ monad wrap (exception.throw ..cannot_make_directory [path])) + + (#.Cons head tail) + (case head + "" (\ monad wrap (exception.throw ..cannot_make_directory [path])) + _ (loop [current (if rooted? + (format (\ fs separator) head) + head) + next tail] + (do monad + [? (..check_or_make_directory monad fs current)] + (case ? + (#try.Success _) + (case next + #.Nil + (wrap (#try.Success [])) + + (#.Cons head tail) + (recur (format current (\ fs separator) head) + tail)) + + (#try.Failure error) + (wrap (#try.Failure error))))))))) + +(def: #export (make_file monad fs content path) + (All [!] (-> (Monad !) (System !) Binary Path (! (Try Any)))) + (do monad + [? (\ fs file? path)] + (if ? + (wrap (exception.throw ..cannot_make_file [path])) + (\ fs write content path)))) diff --git a/stdlib/source/library/lux/world/file/watch.lux b/stdlib/source/library/lux/world/file/watch.lux new file mode 100644 index 000000000..df655ed9c --- /dev/null +++ b/stdlib/source/library/lux/world/file/watch.lux @@ -0,0 +1,459 @@ +(.module: + [library + [lux #* + ["@" target] + ["." ffi (#+ import:)] + [abstract + [predicate (#+ Predicate)] + ["." monad (#+ do)]] + [control + ["." io (#+ IO)] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + [concurrency + ["." promise (#+ Promise)] + ["." stm (#+ STM Var)]]] + [data + ["." product] + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary (#+ Dictionary)] + ["." list ("#\." functor monoid fold)] + ["." set] + ["." array]]] + [math + [number + ["n" nat]]] + [time + ["." instant (#+ Instant) ("#\." equivalence)]] + [type + [abstract (#+ abstract: :representation :abstraction)]]]] + ["." //]) + +(abstract: #export Concern + {#create Bit + #modify Bit + #delete Bit} + + (def: none + Concern + (:abstraction + {#create false + #modify false + #delete false})) + + (template [<concern> <predicate> <event> <create> <modify> <delete>] + [(def: #export <concern> + Concern + (:abstraction + {#create <create> + #modify <modify> + #delete <delete>})) + + (def: #export <predicate> + (Predicate Concern) + (|>> :representation (get@ <event>)))] + + [creation creation? #create + true false false] + [modification modification? #modify + false true false] + [deletion deletion? #delete + false false true] + ) + + (def: #export (also left right) + (-> Concern Concern Concern) + (:abstraction + {#create (or (..creation? left) (..creation? right)) + #modify (or (..modification? left) (..modification? right)) + #delete (or (..deletion? left) (..deletion? right))})) + + (def: #export all + Concern + ($_ ..also + ..creation + ..modification + ..deletion + )) + ) + +(interface: #export (Watcher !) + (: (-> Concern //.Path (! (Try Any))) + start) + (: (-> //.Path (! (Try Concern))) + concern) + (: (-> //.Path (! (Try Concern))) + stop) + (: (-> [] (! (Try (List [Concern //.Path])))) + poll)) + +(template [<name>] + [(exception: #export (<name> {path //.Path}) + (exception.report + ["Path" (%.text path)]))] + + [not_being_watched] + [cannot_poll_a_non_existent_directory] + ) + +(type: File_Tracker + (Dictionary //.Path Instant)) + +(type: Directory_Tracker + (Dictionary //.Path [Concern File_Tracker])) + +(def: (update_watch! new_concern path tracker) + (-> Concern //.Path (Var Directory_Tracker) (STM Bit)) + (do {! stm.monad} + [@tracker (stm.read tracker)] + (case (dictionary.get path @tracker) + (#.Some [old_concern last_modified]) + (do ! + [_ (stm.update (dictionary.put path [new_concern last_modified]) tracker)] + (wrap true)) + + #.None + (wrap false)))) + +(def: (file_tracker fs directory) + (-> (//.System Promise) //.Path (Promise (Try File_Tracker))) + (do {! (try.with promise.monad)} + [files (\ fs directory_files directory)] + (monad.fold ! + (function (_ file tracker) + (do ! + [last_modified (\ fs last_modified file)] + (wrap (dictionary.put file last_modified tracker)))) + (: File_Tracker + (dictionary.new text.hash)) + files))) + +(def: (poll_files fs directory) + (-> (//.System Promise) //.Path (Promise (Try (List [//.Path Instant])))) + (do {! (try.with promise.monad)} + [files (\ fs directory_files directory)] + (monad.map ! (function (_ file) + (|> file + (\ fs last_modified) + (\ ! map (|>> [file])))) + files))) + +(def: (poll_directory_changes fs [directory [concern file_tracker]]) + (-> (//.System Promise) [//.Path [Concern File_Tracker]] + (Promise (Try [[//.Path [Concern File_Tracker]] + [(List [//.Path Instant]) + (List [//.Path Instant Instant]) + (List //.Path)]]))) + (do {! (try.with promise.monad)} + [current_files (..poll_files fs directory) + #let [creations (if (..creation? concern) + (list.filter (|>> product.left (dictionary.key? file_tracker) not) + current_files) + (list)) + available (|> current_files + (list\map product.left) + (set.from_list text.hash)) + deletions (if (..deletion? concern) + (|> (dictionary.entries file_tracker) + (list\map product.left) + (list.filter (|>> (set.member? available) not))) + (list)) + modifications (list.all (function (_ [path current_modification]) + (do maybe.monad + [previous_modification (dictionary.get path file_tracker)] + (wrap [path previous_modification current_modification]))) + current_files)]] + (wrap [[directory + [concern + (let [with_deletions (list\fold dictionary.remove file_tracker deletions) + with_creations (list\fold (function (_ [path last_modified] tracker) + (dictionary.put path last_modified tracker)) + with_deletions + creations) + with_modifications (list\fold (function (_ [path previous_modification current_modification] tracker) + (dictionary.put path current_modification tracker)) + with_creations + modifications)] + with_modifications)]] + [creations + modifications + deletions]]))) + +(def: #export (polling fs) + (-> (//.System Promise) (Watcher Promise)) + (let [tracker (: (Var Directory_Tracker) + (stm.var (dictionary.new text.hash)))] + (implementation + (def: (start new_concern path) + (do {! promise.monad} + [exists? (\ fs directory? path)] + (if exists? + (do ! + [updated? (stm.commit (..update_watch! new_concern path tracker))] + (if updated? + (wrap (#try.Success [])) + (do (try.with !) + [file_tracker (..file_tracker fs path)] + (do ! + [_ (stm.commit (stm.update (dictionary.put path [new_concern file_tracker]) tracker))] + (wrap (#try.Success [])))))) + (wrap (exception.throw ..cannot_poll_a_non_existent_directory [path]))))) + (def: (concern path) + (stm.commit + (do stm.monad + [@tracker (stm.read tracker)] + (wrap (case (dictionary.get path @tracker) + (#.Some [concern file_tracker]) + (#try.Success concern) + + #.None + (exception.throw ..not_being_watched [path])))))) + (def: (stop path) + (stm.commit + (do {! stm.monad} + [@tracker (stm.read tracker)] + (case (dictionary.get path @tracker) + (#.Some [concern file_tracker]) + (do ! + [_ (stm.update (dictionary.remove path) tracker)] + (wrap (#try.Success concern))) + + #.None + (wrap (exception.throw ..not_being_watched [path])))))) + (def: (poll _) + (do promise.monad + [@tracker (stm.commit (stm.read tracker))] + (do {! (try.with promise.monad)} + [changes (|> @tracker + dictionary.entries + (monad.map ! (..poll_directory_changes fs))) + _ (do promise.monad + [_ (stm.commit (stm.write (|> changes + (list\map product.left) + (dictionary.from_list text.hash)) + tracker))] + (wrap (#try.Success []))) + #let [[creations modifications deletions] + (list\fold (function (_ [_ [creations modifications deletions]] + [all_creations all_modifications all_deletions]) + [(list\compose creations all_creations) + (list\compose modifications all_modifications) + (list\compose deletions all_deletions)]) + [(list) (list) (list)] + changes)]] + (wrap ($_ list\compose + (list\map (|>> product.left [..creation]) creations) + (|> modifications + (list.filter (function (_ [path previous_modification current_modification]) + (not (instant\= previous_modification current_modification)))) + (list\map (|>> product.left [..modification]))) + (list\map (|>> [..deletion]) deletions) + ))))) + ))) + +(def: #export (mock separator) + (-> Text [(//.System Promise) (Watcher Promise)]) + (let [fs (//.mock separator)] + [fs + (..polling fs)])) + +(with_expansions [<jvm> (as_is (import: java/lang/Object) + + (import: java/lang/String) + + (import: (java/util/List a) + ["#::." + (size [] int) + (get [int] a)]) + + (def: (default_list list) + (All [a] (-> (java/util/List a) (List a))) + (let [size (.nat (java/util/List::size list))] + (loop [idx 0 + output #.Nil] + (if (n.< size idx) + (recur (inc idx) + (#.Cons (java/util/List::get (.int idx) list) + output)) + output)))) + + (import: (java/nio/file/WatchEvent$Kind a)) + + (import: (java/nio/file/WatchEvent a) + ["#::." + (kind [] (java/nio/file/WatchEvent$Kind a))]) + + (import: java/nio/file/Watchable) + + (import: java/nio/file/Path + ["#::." + (register [java/nio/file/WatchService [(java/nio/file/WatchEvent$Kind [? < java/lang/Object])]] #io #try java/nio/file/WatchKey) + (toString [] java/lang/String)]) + + (import: java/nio/file/StandardWatchEventKinds + ["#::." + (#static ENTRY_CREATE (java/nio/file/WatchEvent$Kind java/nio/file/Path)) + (#static ENTRY_MODIFY (java/nio/file/WatchEvent$Kind java/nio/file/Path)) + (#static ENTRY_DELETE (java/nio/file/WatchEvent$Kind java/nio/file/Path))]) + + (def: (default_event_concern event) + (All [a] + (-> (java/nio/file/WatchEvent a) Concern)) + (let [kind (:as (java/nio/file/WatchEvent$Kind java/nio/file/Path) + (java/nio/file/WatchEvent::kind event))] + (cond (is? (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE) + kind) + ..creation + + (is? (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY) + kind) + ..modification + + (is? (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE) + kind) + ..deletion + + ## else + ..none + ))) + + (import: java/nio/file/WatchKey + ["#::." + (reset [] #io boolean) + (cancel [] #io void) + (watchable [] java/nio/file/Watchable) + (pollEvents [] #io (java/util/List (java/nio/file/WatchEvent ?)))]) + + (def: default_key_concern + (-> java/nio/file/WatchKey (IO Concern)) + (|>> java/nio/file/WatchKey::pollEvents + (\ io.monad map (|>> ..default_list + (list\map default_event_concern) + (list\fold ..also ..none))))) + + (import: java/nio/file/WatchService + ["#::." + (poll [] #io #try #? java/nio/file/WatchKey)]) + + (import: java/nio/file/FileSystem + ["#::." + (newWatchService [] #io #try java/nio/file/WatchService)]) + + (import: java/nio/file/FileSystems + ["#::." + (#static getDefault [] java/nio/file/FileSystem)]) + + (import: java/io/File + ["#::." + (new [java/lang/String]) + (toPath [] java/nio/file/Path)]) + + (type: Watch_Event + (java/nio/file/WatchEvent$Kind java/lang/Object)) + + (def: (default_start watch_events watcher path) + (-> (List Watch_Event) java/nio/file/WatchService //.Path (Promise (Try java/nio/file/WatchKey))) + (let [watch_events' (list\fold (function (_ [index watch_event] watch_events') + (ffi.array_write index watch_event watch_events')) + (ffi.array (java/nio/file/WatchEvent$Kind java/lang/Object) + (list.size watch_events)) + (list.enumeration watch_events))] + (promise.future + (java/nio/file/Path::register watcher + watch_events' + (|> path java/io/File::new java/io/File::toPath))))) + + (def: (default_poll watcher) + (-> java/nio/file/WatchService (IO (Try (List [Concern //.Path])))) + (loop [output (: (List [Concern //.Path]) + (list))] + (do (try.with io.monad) + [?key (java/nio/file/WatchService::poll watcher)] + (case ?key + (#.Some key) + (do {! io.monad} + [valid? (java/nio/file/WatchKey::reset key)] + (if valid? + (do ! + [#let [path (|> key + java/nio/file/WatchKey::watchable + (:as java/nio/file/Path) + java/nio/file/Path::toString + (:as //.Path))] + concern (..default_key_concern key)] + (recur (#.Cons [concern path] + output))) + (recur output))) + + #.None + (wrap output))))) + + (def: (watch_events concern) + (-> Concern (List Watch_Event)) + ($_ list\compose + (if (..creation? concern) + (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE))) + (list)) + (if (..modification? concern) + (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY))) + (list)) + (if (..deletion? concern) + (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE))) + (list)) + )) + + (def: #export default + (IO (Try (Watcher Promise))) + (do (try.with io.monad) + [watcher (java/nio/file/FileSystem::newWatchService + (java/nio/file/FileSystems::getDefault)) + #let [tracker (stm.var (: (Dictionary //.Path [Concern java/nio/file/WatchKey]) + (dictionary.new text.hash))) + + stop (: (-> //.Path (Promise (Try Concern))) + (function (_ path) + (do {! promise.monad} + [@tracker (stm.commit (stm.read tracker))] + (case (dictionary.get path @tracker) + (#.Some [concern key]) + (do ! + [_ (promise.future + (java/nio/file/WatchKey::cancel key)) + _ (stm.commit (stm.update (dictionary.remove path) tracker))] + (wrap (#try.Success concern))) + + #.None + (wrap (exception.throw ..not_being_watched [path]))))))]] + (wrap (: (Watcher Promise) + (implementation + (def: (start concern path) + (do promise.monad + [?concern (stop path)] + (do (try.with promise.monad) + [key (..default_start (..watch_events (..also (try.default ..none ?concern) + concern)) + watcher + path)] + (do promise.monad + [_ (stm.commit (stm.update (dictionary.put path [concern key]) tracker))] + (wrap (#try.Success [])))))) + (def: (concern path) + (do promise.monad + [@tracker (stm.commit (stm.read tracker))] + (case (dictionary.get path @tracker) + (#.Some [concern key]) + (wrap (#try.Success concern)) + + #.None + (wrap (exception.throw ..not_being_watched [path]))))) + (def: stop stop) + (def: (poll _) + (promise.future (..default_poll watcher))) + ))))) + )] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>)} + (as_is))) diff --git a/stdlib/source/library/lux/world/input/keyboard.lux b/stdlib/source/library/lux/world/input/keyboard.lux new file mode 100644 index 000000000..8c65fe493 --- /dev/null +++ b/stdlib/source/library/lux/world/input/keyboard.lux @@ -0,0 +1,112 @@ +(.module: + [library + [lux #*]]) + +(type: #export Key + Nat) + +(template [<code> <name>] + [(def: #export <name> Key <code>)] + + [00008 back_space] + [00010 enter] + [00016 shift] + [00017 control] + [00018 alt] + [00020 caps_lock] + [00027 escape] + [00032 space] + [00033 page_up] + [00034 page_down] + [00035 end] + [00036 home] + + [00037 left] + [00038 up] + [00039 right] + [00040 down] + + [00065 a] + [00066 b] + [00067 c] + [00068 d] + [00069 e] + [00070 f] + [00071 g] + [00072 h] + [00073 i] + [00074 j] + [00075 k] + [00076 l] + [00077 m] + [00078 n] + [00079 o] + [00080 p] + [00081 q] + [00082 r] + [00083 s] + [00084 t] + [00085 u] + [00086 v] + [00087 w] + [00088 x] + [00089 y] + [00090 z] + + [00096 num_pad_0] + [00097 num_pad_1] + [00098 num_pad_2] + [00099 num_pad_3] + [00100 num_pad_4] + [00101 num_pad_5] + [00102 num_pad_6] + [00103 num_pad_7] + [00104 num_pad_8] + [00105 num_pad_9] + + [00127 delete] + [00144 num_lock] + [00145 scroll_lock] + [00154 print_screen] + [00155 insert] + [00524 windows] + + [00112 f1] + [00113 f2] + [00114 f3] + [00115 f4] + [00116 f5] + [00117 f6] + [00118 f7] + [00119 f8] + [00120 f9] + [00121 f10] + [00122 f11] + [00123 f12] + [61440 f13] + [61441 f14] + [61442 f15] + [61443 f16] + [61444 f17] + [61445 f18] + [61446 f19] + [61447 f20] + [61448 f21] + [61449 f22] + [61450 f23] + [61451 f24] + ) + +(type: #export Press + {#pressed? Bit + #input Key}) + +(template [<bit> <name>] + [(def: #export (<name> key) + (-> Key Press) + {#pressed? <bit> + #input key})] + + [#0 release] + [#1 press] + ) diff --git a/stdlib/source/library/lux/world/net.lux b/stdlib/source/library/lux/world/net.lux new file mode 100644 index 000000000..cea1b4a7d --- /dev/null +++ b/stdlib/source/library/lux/world/net.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux (#- Location)]]) + +(type: #export Address Text) + +(type: #export Port Nat) + +(type: #export URL Text) + +(type: #export Location + {#address Address + #port Port}) diff --git a/stdlib/source/library/lux/world/net/http.lux b/stdlib/source/library/lux/world/net/http.lux new file mode 100644 index 000000000..8e205e2a0 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http.lux @@ -0,0 +1,80 @@ +(.module: + [library + [lux #* + [control + [try (#+ Try)] + [concurrency + [promise (#+ Promise)] + [frp (#+ Channel)]] + [parser + ["." environment (#+ Environment)]]] + [data + [binary (#+ Binary)]]]] + [// (#+ URL) + [uri (#+ URI)]]) + +(type: #export Version + Text) + +(type: #export Method + #Post + #Get + #Put + #Patch + #Delete + #Head + #Connect + #Options + #Trace) + +(type: #export Port + Nat) + +(type: #export Status + Nat) + +(type: #export Headers + Environment) + +(def: #export empty + Headers + environment.empty) + +(type: #export Header + (-> Headers Headers)) + +(type: #export (Body !) + (-> (Maybe Nat) (! (Try [Nat Binary])))) + +(type: #export Scheme + #HTTP + #HTTPS) + +(type: #export Address + {#port Port + #host Text}) + +(type: #export Identification + {#local Address + #remote Address}) + +(type: #export Protocol + {#version Version + #scheme Scheme}) + +(type: #export Resource + {#method Method + #uri URI}) + +(type: #export (Message !) + {#headers Headers + #body (Body !)}) + +(type: #export (Request !) + [Identification Protocol Resource (Message !)]) + +(type: #export (Response !) + [Status (Message !)]) + +(type: #export (Server !) + (-> (Request !) (! (Response !)))) diff --git a/stdlib/source/library/lux/world/net/http/client.lux b/stdlib/source/library/lux/world/net/http/client.lux new file mode 100644 index 000000000..5a7a93e31 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/client.lux @@ -0,0 +1,227 @@ +(.module: + [library + [lux #* + ["@" target] + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." io (#+ IO)] + ["." try (#+ Try)] + [concurrency + ["." promise (#+ Promise)]]] + [data + ["." binary (#+ Binary)] + ["." maybe ("#\." functor)] + ["." text] + [collection + ["." dictionary]]] + [math + [number + ["n" nat] + ["i" int]]]]] + ["." // + [// (#+ URL)]]) + +(interface: #export (Client !) + (: (-> //.Method URL //.Headers (Maybe Binary) + (! (Try (//.Response !)))) + request)) + +(template [<name> <method>] + [(def: #export (<name> url headers data client) + (All [!] + (-> URL //.Headers (Maybe Binary) (Client !) + (! (Try (//.Response !))))) + (\ client request <method> url headers data))] + + [post #//.Post] + [get #//.Get] + [put #//.Put] + [patch #//.Patch] + [delete #//.Delete] + [head #//.Head] + [connect #//.Connect] + [options #//.Options] + [trace #//.Trace] + ) + +(def: default_buffer_size + (n.* 1,024 1,024)) + +(def: empty_body + [Nat Binary] + [0 (binary.create 0)]) + +(def: (body_of data) + (-> Binary [Nat Binary]) + [(binary.size data) data]) + +(with_expansions [<jvm> (as_is (ffi.import: java/lang/String) + + (ffi.import: java/lang/AutoCloseable + ["#::." + (close [] #io #try void)]) + + (ffi.import: java/io/InputStream) + + (ffi.import: java/io/OutputStream + ["#::." + (flush [] #io #try void) + (write [[byte]] #io #try void)]) + + (ffi.import: java/net/URLConnection + ["#::." + (setDoOutput [boolean] #io #try void) + (setRequestProperty [java/lang/String java/lang/String] #io #try void) + (getInputStream [] #io #try java/io/InputStream) + (getOutputStream [] #io #try java/io/OutputStream) + (getHeaderFieldKey [int] #io #try #? java/lang/String) + (getHeaderField [int] #io #try #? java/lang/String)]) + + (ffi.import: java/net/HttpURLConnection + ["#::." + (setRequestMethod [java/lang/String] #io #try void) + (getResponseCode [] #io #try int)]) + + (ffi.import: java/net/URL + ["#::." + (new [java/lang/String]) + (openConnection [] #io #try java/net/URLConnection)]) + + (ffi.import: java/io/BufferedInputStream + ["#::." + (new [java/io/InputStream]) + (read [[byte] int int] #io #try int)]) + + (def: jvm_method + (-> //.Method Text) + (|>> (case> #//.Post "POST" + #//.Get "GET" + #//.Put "PUT" + #//.Patch "PATCH" + #//.Delete "DELETE" + #//.Head "HEAD" + #//.Connect "CONNECT" + #//.Options "OPTIONS" + #//.Trace "TRACE"))) + + (def: (default_body input) + (-> java/io/BufferedInputStream (//.Body IO)) + (|>> (maybe\map (|>> [true])) + (maybe.default [false ..default_buffer_size]) + (case> [_ 0] + (do (try.with io.monad) + [_ (java/lang/AutoCloseable::close input)] + (wrap ..empty_body)) + + [partial? buffer_size] + (let [buffer (binary.create buffer_size)] + (if partial? + (loop [so_far +0] + (do {! (try.with io.monad)} + [#let [remaining (i.- so_far (.int buffer_size))] + bytes_read (java/io/BufferedInputStream::read buffer so_far remaining input)] + (case bytes_read + -1 (do ! + [_ (java/lang/AutoCloseable::close input)] + (wrap [(.nat so_far) buffer])) + +0 (recur so_far) + _ (if (i.= remaining bytes_read) + (wrap [buffer_size buffer]) + (recur (i.+ bytes_read so_far)))))) + (loop [so_far +0 + output (\ binary.monoid identity)] + (do {! (try.with io.monad)} + [#let [remaining (i.- so_far (.int buffer_size))] + bytes_read (java/io/BufferedInputStream::read buffer so_far remaining input)] + (case bytes_read + -1 (do ! + [_ (java/lang/AutoCloseable::close input)] + (case so_far + +0 (wrap (..body_of output)) + _ (|> buffer + (binary.slice 0 (.nat so_far)) + (\ try.functor map + (|>> (\ binary.monoid compose output) + ..body_of)) + (\ io.monad wrap)))) + +0 (recur so_far output) + _ (if (i.= remaining bytes_read) + (recur +0 + (\ binary.monoid compose output buffer)) + (recur (i.+ bytes_read so_far) + output)))))))))) + + (def: (default_headers connection) + (-> java/net/HttpURLConnection (IO (Try //.Headers))) + (loop [index +0 + headers //.empty] + (do {! (try.with io.monad)} + [?name (java/net/URLConnection::getHeaderFieldKey index connection)] + (case ?name + (#.Some name) + (do ! + [?value (java/net/URLConnection::getHeaderField index connection)] + (recur (inc index) + (dictionary.put name (maybe.default "" ?value) headers))) + + #.None + (wrap headers))))) + + (implementation: #export default + (Client IO) + + (def: (request method url headers data) + (: (IO (Try (//.Response IO))) + (do {! (try.with io.monad)} + [connection (|> url java/net/URL::new java/net/URL::openConnection) + #let [connection (:as java/net/HttpURLConnection connection)] + _ (java/net/HttpURLConnection::setRequestMethod (..jvm_method method) connection) + _ (monad.map ! (function (_ [name value]) + (java/net/URLConnection::setRequestProperty name value connection)) + (dictionary.entries headers)) + _ (case data + (#.Some data) + (do ! + [_ (java/net/URLConnection::setDoOutput true connection) + stream (java/net/URLConnection::getOutputStream connection) + _ (java/io/OutputStream::write data stream) + _ (java/io/OutputStream::flush stream) + _ (java/lang/AutoCloseable::close stream)] + (wrap [])) + + #.None + (wrap [])) + status (java/net/HttpURLConnection::getResponseCode connection) + headers (..default_headers connection) + input (|> connection + java/net/URLConnection::getInputStream + (\ ! map (|>> java/io/BufferedInputStream::new)))] + (wrap [(.nat status) + {#//.headers headers + #//.body (..default_body input)}]))))))] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>)} + (as_is))) + +(implementation: #export (async client) + (-> (Client IO) (Client Promise)) + + (def: (request method url headers data) + (|> (\ client request method url headers data) + promise.future + (\ promise.monad map + (|>> (case> (#try.Success [status message]) + (#try.Success [status (update@ #//.body (: (-> (//.Body IO) (//.Body Promise)) + (function (_ body) + (|>> body promise.future))) + message)]) + + (#try.Failure error) + (#try.Failure error))))))) + +(def: #export headers + (-> (List [Text Text]) //.Headers) + (dictionary.from_list text.hash)) diff --git a/stdlib/source/library/lux/world/net/http/cookie.lux b/stdlib/source/library/lux/world/net/http/cookie.lux new file mode 100644 index 000000000..08a75fecc --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/cookie.lux @@ -0,0 +1,88 @@ +(.module: + [library + [lux #* + [control + [monad (#+ do)] + ["." try (#+ Try)] + ["p" parser ("#\." monad) + ["l" text (#+ Parser)]]] + [data + [number + ["i" int]] + [text + ["%" format (#+ format)]] + [format + ["." context (#+ Context)]] + [collection + ["." dictionary]]] + [time + ["." duration (#+ Duration)]]]] + ["." // (#+ Header) + ["." header]]) + +(type: #export Directive (-> Text Text)) + +(def: (directive extension) + (-> Text Directive) + (function (_ so-far) + (format so-far "; " extension))) + +(def: #export (set name value) + (-> Text Text Header) + (header.add "Set-Cookie" (format name "=" value))) + +(def: #export (max-age duration) + (-> Duration Directive) + (let [seconds (duration.query duration.second duration)] + (..directive (format "Max-Age=" (if (i.< +0 seconds) + (%.int seconds) + (%.nat (.nat seconds))))))) + +(template [<name> <prefix>] + [(def: #export (<name> value) + (-> Text Directive) + (..directive (format <prefix> "=" value)))] + + [domain "Domain"] + [path "Path"] + ) + +(template [<name> <tag>] + [(def: #export <name> + Directive + (..directive <tag>))] + + [secure "Secure"] + [http-only "HttpOnly"] + ) + +(type: #export CSRF-Policy + #Strict + #Lax) + +(def: #export (same-site policy) + (-> CSRF-Policy Directive) + (..directive (format "SameSite=" (case policy + #Strict "Strict" + #Lax "Lax")))) + +(def: (cookie context) + (-> Context (Parser Context)) + (do p.monad + [key (l.slice (l.many! (l.none-of! "="))) + _ (l.this "=") + value (l.slice (l.many! (l.none-of! ";")))] + (wrap (dictionary.put key value context)))) + +(def: (cookies context) + (-> Context (Parser Context)) + ($_ p.either + (do p.monad + [context' (..cookie context) + _ (l.this "; ")] + (cookies context')) + (p\wrap context))) + +(def: #export (get header) + (-> Text (Try Context)) + (l.run header (..cookies context.empty))) diff --git a/stdlib/source/library/lux/world/net/http/header.lux b/stdlib/source/library/lux/world/net/http/header.lux new file mode 100644 index 000000000..e5b1882ad --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/header.lux @@ -0,0 +1,35 @@ +(.module: + [library + [lux #* + [control + [pipe (#+ case>)]] + [data + [text + ["%" format (#+ format)]] + [collection + ["." dictionary (#+ Dictionary)]]]]] + [// (#+ Header) + ["." mime (#+ MIME)] + [// (#+ URL)]]) + +(def: #export (add name value) + (-> Text Text Header) + (dictionary.upsert name "" + (|>> (case> + "" + value + + previous + (format previous "," value))))) + +(def: #export content-length + (-> Nat Header) + (|>> %.nat (..add "Content-Length"))) + +(def: #export content-type + (-> MIME Header) + (|>> mime.name (..add "Content-Type"))) + +(def: #export location + (-> URL Header) + (..add "Location")) diff --git a/stdlib/source/library/lux/world/net/http/mime.lux b/stdlib/source/library/lux/world/net/http/mime.lux new file mode 100644 index 000000000..859b0840e --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/mime.lux @@ -0,0 +1,100 @@ +(.module: + [library + [lux #* + [data + ["." text + ["%" format (#+ format)] + ["." encoding (#+ Encoding)]]] + [type + abstract]]]) + +(abstract: #export MIME + Text + + {#doc "Multipurpose Internet Mail Extensions"} + + (def: #export mime + (-> Text MIME) + (|>> :abstraction)) + + (def: #export name + (-> MIME Text) + (|>> :representation)) + ) + +## https://developer.mozilla.org/en-US/docs/Web/HTTP/Basics_of_HTTP/MIME_types/Complete_list_of_MIME_types +(template [<name> <type>] + [(def: #export <name> MIME (..mime <type>))] + + [aac-audio "audio/aac"] + [abiword "application/x-abiword"] + [avi "video/x-msvideo"] + [amazon-kindle-ebook "application/vnd.amazon.ebook"] + [binary "application/octet-stream"] + [bitmap "image/bmp"] + [bzip "application/x-bzip"] + [bzip2 "application/x-bzip2"] + [c-shell "application/x-csh"] + [css "text/css"] + [csv "text/csv"] + [microsoft-word "application/msword"] + [microsoft-word-openxml "application/vnd.openxmlformats-officedocument.wordprocessingml.document"] + [ms-embedded-opentype-fonts "application/vnd.ms-fontobject"] + [epub "application/epub+zip"] + [ecmascript "application/ecmascript"] + [gif "image/gif"] + [html "text/html"] + [icon "image/x-icon"] + [icalendar "text/calendar"] + [jar "application/java-archive"] + [jpeg "image/jpeg"] + [javascript "application/javascript"] + [json "application/json"] + [midi "audio/midi"] + [mpeg "video/mpeg"] + [apple-installer-package "application/vnd.apple.installer+xml"] + [opendocument-presentation "application/vnd.oasis.opendocument.presentation"] + [opendocument-spreadsheet "application/vnd.oasis.opendocument.spreadsheet"] + [opendocument-text "application/vnd.oasis.opendocument.text"] + [ogg-audio "audio/ogg"] + [ogg-video "video/ogg"] + [ogg "application/ogg"] + [opentype-font "font/otf"] + [png "image/png"] + [pdf "application/pdf"] + [microsoft-powerpoint "application/vnd.ms-powerpoint"] + [microsoft-powerpoint-openxml "application/vnd.openxmlformats-officedocument.presentationml.presentation"] + [rar "application/x-rar-compressed"] + [rtf "application/rtf"] + [bourne-shell "application/x-sh"] + [svg "image/svg+xml"] + [flash "application/x-shockwave-flash"] + [tar "application/x-tar"] + [tiff "image/tiff"] + [typescript "application/typescript"] + [truetype-font "font/ttf"] + [microsoft-visio "application/vnd.visio"] + [wav "audio/wav"] + [webm-audio "audio/webm"] + [webm-video "video/webm"] + [webp "image/webp"] + [woff "font/woff"] + [woff2 "font/woff2"] + [xhtml "application/xhtml+xml"] + [microsoft-excel "application/vnd.ms-excel"] + [microsoft-excel-openxml "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"] + [xml "application/xml"] + [xul "application/vnd.mozilla.xul+xml"] + [zip "application/zip"] + [!3gpp-audio "audio/3gpp"] + [!3gpp "video/3gpp"] + [!3gpp2-audio "audio/3gpp2"] + [!3gpp2 "video/3gpp2"] + [!7z "application/x-7z-compressed"] + ) + +(def: #export (text encoding) + (-> Encoding MIME) + (..mime (format "text/plain; charset=" text.double-quote (encoding.name encoding) text.double-quote))) + +(def: #export utf-8 MIME (..text encoding.utf-8)) diff --git a/stdlib/source/library/lux/world/net/http/query.lux b/stdlib/source/library/lux/world/net/http/query.lux new file mode 100644 index 000000000..b6b8936b7 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/query.lux @@ -0,0 +1,65 @@ +(.module: + [library + [lux #* + [control + pipe + [monad (#+ do)] + ["." try (#+ Try)] + ["p" parser + ["l" text (#+ Parser)]]] + [data + [number + ["." nat]] + ["." text + ["%" format (#+ format)]] + [format + ["." context (#+ Context)]] + [collection + ["." dictionary]]]]]) + +(def: component + (Parser Text) + (p.rec + (function (_ component) + (do {! p.monad} + [head (l.some (l.none-of "+%&;"))] + ($_ p.either + (p.after (p.either l.end + (l.this "&")) + (wrap head)) + (do ! + [_ (l.this "+") + tail component] + (wrap (format head " " tail))) + (do ! + [_ (l.this "%") + code (|> (l.exactly 2 l.hexadecimal) + (p.codec nat.hex) + (\ ! map text.from-code)) + tail component] + (wrap (format head code tail)))))))) + +(def: (form context) + (-> Context (Parser Context)) + ($_ p.either + (do p.monad + [_ l.end] + (wrap context)) + (do {! p.monad} + [key (l.some (l.none-of "=&;")) + key (l.local key ..component)] + (p.either (do ! + [_ (l.this "=") + value ..component] + (form (dictionary.put key value context))) + (do ! + [_ ($_ p.or + (l.one-of "&;") + l.end)] + (form (dictionary.put key "" context))))) + ## if invalid form data, just stop parsing... + (\ p.monad wrap context))) + +(def: #export (parameters raw) + (-> Text (Try Context)) + (l.run raw (..form context.empty))) diff --git a/stdlib/source/library/lux/world/net/http/request.lux b/stdlib/source/library/lux/world/net/http/request.lux new file mode 100644 index 000000000..4a6911798 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/request.lux @@ -0,0 +1,128 @@ +(.module: + [library + [lux #* + [control + pipe + ["." monad (#+ do)] + ["." try (#+ Try)] + [concurrency + ["." promise (#+ Promise)] + ["." frp]] + [parser + ["<.>" json]]] + [data + ["." maybe] + ["." number + ["n" nat]] + ["." text + ["." encoding]] + [format + ["." json (#+ JSON)] + ["." context (#+ Context Property)]] + [collection + ["." list ("#\." functor fold)] + ["." dictionary]]] + [world + ["." binary (#+ Binary)]]]] + ["." // (#+ Body Response Server) + ["#." response] + ["#." query] + ["#." cookie]]) + +(def: (merge inputs) + (-> (List Binary) Binary) + (let [[_ output] (try.assume + (monad.fold try.monad + (function (_ input [offset output]) + (let [amount (binary.size input)] + (\ try.functor map (|>> [(n.+ amount offset)]) + (binary.copy amount 0 input offset output)))) + [0 (|> inputs + (list\map binary.size) + (list\fold n.+ 0) + binary.create)] + inputs))] + output)) + +(def: (read-text-body body) + (-> Body (Promise (Try Text))) + (do promise.monad + [blobs (frp.consume body)] + (wrap (\ encoding.utf8 decode (merge blobs))))) + +(def: failure (//response.bad-request "")) + +(def: #export (json reader server) + (All [a] (-> (<json>.Reader a) (-> a Server) Server)) + (function (_ (^@ request [identification protocol resource message])) + (do promise.monad + [?raw (read-text-body (get@ #//.body message))] + (case (do try.monad + [raw ?raw + content (\ json.codec decode raw)] + (json.run content reader)) + (#try.Success input) + (server input request) + + (#try.Failure error) + (promise.resolved ..failure))))) + +(def: #export (text server) + (-> (-> Text Server) Server) + (function (_ (^@ request [identification protocol resource message])) + (do promise.monad + [?raw (read-text-body (get@ #//.body message))] + (case ?raw + (#try.Success content) + (server content request) + + (#try.Failure error) + (promise.resolved ..failure))))) + +(def: #export (query property server) + (All [a] (-> (Property a) (-> a Server) Server)) + (function (_ [identification protocol resource message]) + (let [full (get@ #//.uri resource) + [uri query] (|> full + (text.split-with "?") + (maybe.default [full ""]))] + (case (do try.monad + [query (//query.parameters query) + input (context.run query property)] + (wrap [[identification protocol (set@ #//.uri uri resource) message] + input])) + (#try.Success [request input]) + (server input request) + + (#try.Failure error) + (promise.resolved ..failure))))) + +(def: #export (form property server) + (All [a] (-> (Property a) (-> a Server) Server)) + (function (_ (^@ request [identification protocol resource message])) + (do promise.monad + [?body (read-text-body (get@ #//.body message))] + (case (do try.monad + [body ?body + form (//query.parameters body)] + (context.run form property)) + (#try.Success input) + (server input request) + + (#try.Failure error) + (promise.resolved ..failure))))) + +(def: #export (cookies property server) + (All [a] (-> (Property a) (-> a Server) Server)) + (function (_ (^@ request [identification protocol resource message])) + (case (do try.monad + [cookies (|> (get@ #//.headers message) + (dictionary.get "Cookie") + (maybe.default "") + //cookie.get)] + (context.run cookies property)) + (#try.Success input) + (server input request) + + (#try.Failure error) + (promise.resolved ..failure)))) diff --git a/stdlib/source/library/lux/world/net/http/response.lux b/stdlib/source/library/lux/world/net/http/response.lux new file mode 100644 index 000000000..0ca825a44 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/response.lux @@ -0,0 +1,74 @@ +(.module: + [library + [lux (#- static) + [control + [concurrency + ["." promise] + ["." frp ("#\." monad)]]] + [data + ["." text + ["." encoding]] + [format + ["." html] + ["." css (#+ CSS)] + ["." context] + ["." json (#+ JSON) ("#\." codec)]]] + ["." io] + [world + ["." binary (#+ Binary)]]]] + ["." // (#+ Status Body Response Server) + ["." status] + ["." mime (#+ MIME)] + ["." header] + [// (#+ URL)]]) + +(def: #export (static response) + (-> Response Server) + (function (_ request) + (promise.resolved response))) + +(def: #export empty + (-> Status Response) + (let [body (frp\wrap (\ encoding.utf8 encode ""))] + (function (_ status) + [status + {#//.headers (|> context.empty + (header.content-length 0) + (header.content-type mime.utf-8)) + #//.body body}]))) + +(def: #export (temporary-redirect to) + (-> URL Response) + (let [[status message] (..empty status.temporary-redirect)] + [status (update@ #//.headers (header.location to) message)])) + +(def: #export not-found + Response + (..empty status.not-found)) + +(def: #export (content status type data) + (-> Status MIME Binary Response) + [status + {#//.headers (|> context.empty + (header.content-length (binary.size data)) + (header.content-type type)) + #//.body (frp\wrap data)}]) + +(def: #export bad-request + (-> Text Response) + (|>> (\ encoding.utf8 encode) (content status.bad-request mime.utf-8))) + +(def: #export ok + (-> MIME Binary Response) + (content status.ok)) + +(template [<name> <type> <mime> <pre>] + [(def: #export <name> + (-> <type> Response) + (|>> <pre> (\ encoding.utf8 encode) (..ok <mime>)))] + + [text Text mime.utf-8 (<|)] + [html html.Document mime.html html.html] + [css CSS mime.css css.css] + [json JSON mime.json json\encode] + ) diff --git a/stdlib/source/library/lux/world/net/http/route.lux b/stdlib/source/library/lux/world/net/http/route.lux new file mode 100644 index 000000000..456ed9e36 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/route.lux @@ -0,0 +1,74 @@ +(.module: + [library + [lux (#- or) + [control + [monad (#+ do)] + [concurrency + ["." promise]]] + [data + ["." maybe] + ["." text] + [number + ["n" nat]]]]] + ["." // (#+ URI Server) + ["#." status] + ["#." response]]) + +(template [<scheme> <name>] + [(def: #export (<name> server) + (-> Server Server) + (function (_ (^@ request [identification protocol resource message])) + (case (get@ #//.scheme protocol) + <scheme> + (server request) + + _ + (promise.resolved //response.not-found))))] + + [#//.HTTP http] + [#//.HTTPS https] + ) + +(template [<method> <name>] + [(def: #export (<name> server) + (-> Server Server) + (function (_ (^@ request [identification protocol resource message])) + (case (get@ #//.method resource) + <method> + (server request) + + _ + (promise.resolved //response.not-found))))] + + [#//.Get get] + [#//.Post post] + [#//.Put put] + [#//.Patch patch] + [#//.Delete delete] + [#//.Head head] + [#//.Connect connect] + [#//.Options options] + [#//.Trace trace] + ) + +(def: #export (uri path server) + (-> URI Server Server) + (function (_ [identification protocol resource message]) + (if (text.starts-with? path (get@ #//.uri resource)) + (server [identification + protocol + (update@ #//.uri + (|>> (text.clip' (text.size path)) maybe.assume) + resource) + message]) + (promise.resolved //response.not-found)))) + +(def: #export (or primary alternative) + (-> Server Server Server) + (function (_ request) + (do promise.monad + [response (primary request) + #let [[status message] response]] + (if (n.= //status.not-found status) + (alternative request) + (wrap response))))) diff --git a/stdlib/source/library/lux/world/net/http/status.lux b/stdlib/source/library/lux/world/net/http/status.lux new file mode 100644 index 000000000..fe3f7d90d --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/status.lux @@ -0,0 +1,83 @@ +(.module: + [library + [lux #*]] + [// (#+ Status)]) + +## https://en.wikipedia.org/wiki/List_of_HTTP_status_codes +(template [<status> <name>] + [(def: #export <name> + Status + <status>)] + + ## 1xx Informational response + [100 continue] + [101 switching_protocols] + [102 processing] + [103 early_hints] + + ## 2xx Success + [200 ok] + [201 created] + [202 accepted] + [203 non_authoritative_information] + [204 no_content] + [205 reset_content] + [206 partial_content] + [207 multi_status] + [208 already_reported] + [226 im_used] + + ## 3xx Redirection + [300 multiple_choices] + [301 moved_permanently] + [302 found] + [303 see_other] + [304 not_modified] + [305 use_proxy] + [306 switch_proxy] + [307 temporary_redirect] + [308 permanent_redirect] + + ## 4xx Client errors + [400 bad_request] + [401 unauthorized] + [402 payment_required] + [403 forbidden] + [404 not_found] + [405 method_not_allowed] + [406 not_acceptable] + [407 proxy_authentication_required] + [408 request_timeout] + [409 conflict] + [410 gone] + [411 length_required] + [412 precondition_failed] + [413 payload_too_large] + [414 uri_too_long] + [415 unsupported_media_type] + [416 range_not_satisfiable] + [417 expectation_failed] + [418 im_a_teapot] + [421 misdirected_request] + [422 unprocessable_entity] + [423 locked] + [424 failed_dependency] + [426 upgrade_required] + [428 precondition_required] + [429 too_many_requests] + [431 request_header_fields_too_large] + [451 unavailable_for_legal_reasons] + + ## 5xx Server errors + [500 internal_server_error] + [501 not_implemented] + [502 bad_gateway] + [503 service_unavailable] + [504 gateway_timeout] + [505 http_version_not_supported] + [506 variant_also_negotiates] + [507 insufficient_storage] + [508 loop_detected] + [510 not_extended] + [511 network_authentication_required] + ) diff --git a/stdlib/source/library/lux/world/net/http/version.lux b/stdlib/source/library/lux/world/net/http/version.lux new file mode 100644 index 000000000..2443fda12 --- /dev/null +++ b/stdlib/source/library/lux/world/net/http/version.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #*]] + [// (#+ Version)]) + +(template [<name> <version>] + [(def: #export <name> Version <version>)] + + [v0_9 "0.9"] + [v1_0 "1.0"] + [v1_1 "1.1"] + [v2_0 "2.0"] + ) diff --git a/stdlib/source/library/lux/world/net/uri.lux b/stdlib/source/library/lux/world/net/uri.lux new file mode 100644 index 000000000..2c43cbbd3 --- /dev/null +++ b/stdlib/source/library/lux/world/net/uri.lux @@ -0,0 +1,9 @@ +(.module: + [library + [lux #*]]) + +(type: #export URI + Text) + +(def: #export separator + "/") diff --git a/stdlib/source/library/lux/world/output/video/resolution.lux b/stdlib/source/library/lux/world/output/video/resolution.lux new file mode 100644 index 000000000..24f48182c --- /dev/null +++ b/stdlib/source/library/lux/world/output/video/resolution.lux @@ -0,0 +1,47 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] + [data + ["." product]] + [math + [number + ["." nat]]]]]) + +(type: #export Resolution + {#width Nat + #height Nat}) + +(def: #export hash + (Hash Resolution) + (product.hash nat.hash nat.hash)) + +(def: #export equivalence + (Equivalence Resolution) + (\ ..hash &equivalence)) + +## https://en.wikipedia.org/wiki/Display_resolution#Common_display_resolutions +(template [<name> <width> <height>] + [(def: #export <name> + Resolution + {#width <width> + #height <height>})] + + [svga 800 600] + [wsvga 1024 600] + [xga 1024 768] + [xga+ 1152 864] + [wxga/16:9 1280 720] + [wxga/5:3 1280 768] + [wxga/16:10 1280 800] + [sxga 1280 1024] + [wxga+ 1440 900] + [hd+ 1600 900] + [wsxga+ 1680 1050] + [fhd 1920 1080] + [wuxga 1920 1200] + [wqhd 2560 1440] + [uhd-4k 3840 2160] + ) diff --git a/stdlib/source/library/lux/world/program.lux b/stdlib/source/library/lux/world/program.lux new file mode 100644 index 000000000..8c8a0ac05 --- /dev/null +++ b/stdlib/source/library/lux/world/program.lux @@ -0,0 +1,451 @@ +(.module: + [library + [lux #* + ["@" target] + ["." ffi (#+ import:)] + [abstract + ["." monad (#+ Monad do)]] + [control + ["." function] + ["." io (#+ IO)] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + [concurrency + ["." atom] + ["." promise (#+ Promise)]] + [parser + ["." environment (#+ Environment)]]] + [data + ["." bit ("#\." equivalence)] + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." array (#+ Array)] + ["." dictionary (#+ Dictionary)] + ["." list ("#\." functor)]]] + ["." macro + ["." template]] + [math + [number + ["i" int]]] + [type + abstract]]] + [// + [file (#+ Path)] + [shell (#+ Exit)]]) + +(exception: #export (unknown_environment_variable {name Text}) + (exception.report + ["Name" (%.text name)])) + +(interface: #export (Program !) + (: (-> Any (! (List Text))) + available_variables) + (: (-> Text (! (Try Text))) + variable) + (: Path + home) + (: Path + directory) + (: (-> Exit (! Nothing)) + exit)) + +(def: #export (environment monad program) + (All [!] (-> (Monad !) (Program !) (! Environment))) + (do {! monad} + [variables (\ program available_variables []) + entries (monad.map ! (function (_ name) + (\ ! map (|>> [name]) (\ program variable name))) + variables)] + (wrap (|> entries + (list.all (function (_ [name value]) + (case value + (#try.Success value) + (#.Some [name value]) + + (#try.Failure _) + #.None))) + (dictionary.from_list text.hash))))) + +(`` (implementation: #export (async program) + (-> (Program IO) (Program Promise)) + + (~~ (template [<method>] + [(def: <method> + (\ program <method>))] + + [home] + [directory] + )) + + (~~ (template [<method>] + [(def: <method> + (|>> (\ program <method>) promise.future))] + + [available_variables] + [variable] + [exit] + )))) + +(def: #export (mock environment home directory) + (-> Environment Path Path (Program IO)) + (let [@dead? (atom.atom false)] + (implementation + (def: available_variables + (function.constant (io.io (dictionary.keys environment)))) + (def: (variable name) + (io.io (case (dictionary.get name environment) + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..unknown_environment_variable [name])))) + (def: home + home) + (def: directory + directory) + (def: (exit code) + (io.io (error! (%.int code))))))) + +## Do not trust the values of environment variables +## https://wiki.sei.cmu.edu/confluence/display/java/ENV02-J.+Do+not+trust+the+values+of+environment+variables + +(with_expansions [<jvm> (as_is (import: java/lang/String) + + (import: (java/util/Iterator a) + ["#::." + (hasNext [] boolean) + (next [] a)]) + + (import: (java/util/Set a) + ["#::." + (iterator [] (java/util/Iterator a))]) + + (import: (java/util/Map k v) + ["#::." + (keySet [] (java/util/Set k))]) + + (import: java/lang/System + ["#::." + (#static getenv [] (java/util/Map java/lang/String java/lang/String)) + (#static getenv #as resolveEnv [java/lang/String] #io #? java/lang/String) + (#static getProperty [java/lang/String] #? java/lang/String) + (#static exit [int] #io void)]) + + (def: (jvm\\consume iterator) + (All [a] (-> (java/util/Iterator a) (List a))) + (if (java/util/Iterator::hasNext iterator) + (#.Cons (java/util/Iterator::next iterator) + (jvm\\consume iterator)) + #.Nil)) + )] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>) + @.js (as_is (def: default_exit! + (-> Exit (IO Nothing)) + (|>> %.int error! io.io)) + + (import: NodeJs_Process + ["#::." + (exit [ffi.Number] #io Nothing) + (cwd [] #io Path)]) + + (def: (exit_node_js! code) + (-> Exit (IO Nothing)) + (case (ffi.constant ..NodeJs_Process [process]) + (#.Some process) + (NodeJs_Process::exit (i.frac code) process) + + #.None + (..default_exit! code))) + + (import: Browser_Window + ["#::." + (close [] Nothing)]) + + (import: Browser_Location + ["#::." + (reload [] Nothing)]) + + (def: (exit_browser! code) + (-> Exit (IO Nothing)) + (case [(ffi.constant ..Browser_Window [window]) + (ffi.constant ..Browser_Location [location])] + [(#.Some window) (#.Some location)] + (exec + (Browser_Window::close [] window) + (Browser_Location::reload [] location) + (..default_exit! code)) + + [(#.Some window) #.None] + (exec + (Browser_Window::close [] window) + (..default_exit! code)) + + [#.None (#.Some location)] + (exec + (Browser_Location::reload [] location) + (..default_exit! code)) + + [#.None #.None] + (..default_exit! code))) + + (import: Object + ["#::." + (#static entries [Object] (Array (Array ffi.String)))]) + + (import: NodeJs_OS + ["#::." + (homedir [] #io Path)]) + + (template [<name> <path>] + [(def: (<name> _) + (-> [] (Maybe (-> ffi.String Any))) + (ffi.constant (-> ffi.String Any) <path>))] + + [normal_require [require]] + [global_require [global require]] + [process_load [global process mainModule constructor _load]] + ) + + (def: (require _) + (-> [] (-> ffi.String Any)) + (case [(normal_require []) (global_require []) (process_load [])] + (^or [(#.Some require) _ _] + [_ (#.Some require) _] + [_ _ (#.Some require)]) + require + + _ + (undefined)))) + @.python (as_is (import: os + ["#::." + (#static getcwd [] #io ffi.String) + (#static _exit [ffi.Integer] #io Nothing)]) + + (import: os/path + ["#::." + (#static expanduser [ffi.String] #io ffi.String)]) + + (import: os/environ + ["#::." + (#static keys [] #io (Array ffi.String)) + (#static get [ffi.String] #io #? ffi.String)])) + @.lua (as_is (ffi.import: LuaFile + ["#::." + (read [ffi.String] #io #? ffi.String) + (close [] #io ffi.Boolean)]) + + (ffi.import: (io/popen [ffi.String] #io #try #? LuaFile)) + (ffi.import: (os/getenv [ffi.String] #io #? ffi.String)) + (ffi.import: (os/exit [ffi.Integer] #io Nothing)) + + (def: (run_command default command) + (-> Text Text (IO Text)) + (do {! io.monad} + [outcome (io/popen [command])] + (case outcome + (#try.Success outcome) + (case outcome + (#.Some file) + (do ! + [?output (LuaFile::read ["*l"] file) + _ (LuaFile::close [] file)] + (wrap (maybe.default default ?output))) + + #.None + (wrap default)) + + (#try.Failure _) + (wrap default))))) + @.ruby (as_is (ffi.import: Env #as RubyEnv + ["#::." + (#static keys [] (Array Text)) + (#static fetch [Text] #io #? Text)]) + + (ffi.import: "fileutils" FileUtils #as RubyFileUtils + ["#::." + (#static pwd Path)]) + + (ffi.import: Dir #as RubyDir + ["#::." + (#static home Path)]) + + (ffi.import: Kernel #as RubyKernel + ["#::." + (#static exit [Int] #io Nothing)])) + + ## @.php + ## (as_is (ffi.import: (exit [Int] #io Nothing)) + ## ## https://www.php.net/manual/en/function.exit.php + ## (ffi.import: (getcwd [] #io ffi.String)) + ## ## https://www.php.net/manual/en/function.getcwd.php + ## (ffi.import: (getenv #as getenv/1 [ffi.String] #io ffi.String)) + ## (ffi.import: (getenv #as getenv/0 [] #io (Array ffi.String))) + ## ## https://www.php.net/manual/en/function.getenv.php + ## ## https://www.php.net/manual/en/function.array-keys.php + ## (ffi.import: (array_keys [(Array ffi.String)] (Array ffi.String))) + ## ) + + ## @.scheme + ## (as_is (ffi.import: (exit [Int] #io Nothing)) + ## ## https://srfi.schemers.org/srfi-98/srfi-98.html + ## (abstract: Pair Any) + ## (abstract: PList Any) + ## (ffi.import: (get-environment-variables [] #io PList)) + ## (ffi.import: (car [Pair] Text)) + ## (ffi.import: (cdr [Pair] Text)) + ## (ffi.import: (car #as head [PList] Pair)) + ## (ffi.import: (cdr #as tail [PList] PList))) + } + (as_is))) + +(implementation: #export default + (Program IO) + + (def: (available_variables _) + (with_expansions [<jvm> (io.io (|> (java/lang/System::getenv) + java/util/Map::keySet + java/util/Set::iterator + ..jvm\\consume))] + (for {@.old <jvm> + @.jvm <jvm> + @.js (io.io (if ffi.on_node_js? + (case (ffi.constant Object [process env]) + (#.Some process/env) + (|> (Object::entries [process/env]) + array.to_list + (list\map (|>> (array.read 0) maybe.assume))) + + #.None + (list)) + (list))) + @.python (\ io.monad map array.to_list (os/environ::keys [])) + ## Lua offers no way to get all the environment variables available. + @.lua (io.io (list)) + @.ruby (|> (RubyEnv::keys []) + array.to_list + io.io) + ## @.php (do io.monad + ## [environment (..getenv/0 [])] + ## (wrap (|> environment + ## ..array_keys + ## array.to_list + ## (list\map (function (_ variable) + ## [variable ("php array read" (:as Nat variable) environment)])) + ## (dictionary.from_list text.hash)))) + ## @.scheme (do io.monad + ## [input (..get-environment-variables [])] + ## (loop [input input + ## output environment.empty] + ## (if ("scheme object nil?" input) + ## (wrap output) + ## (let [entry (..head input)] + ## (recur (..tail input) + ## (dictionary.put (..car entry) (..cdr entry) output)))))) + }))) + + (def: (variable name) + (template.let [(!fetch <method>) + [(do io.monad + [value (<method> name)] + (wrap (case value + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..unknown_environment_variable [name]))))]] + (with_expansions [<jvm> (!fetch java/lang/System::resolveEnv)] + (for {@.old <jvm> + @.jvm <jvm> + @.js (io.io (if ffi.on_node_js? + (case (do maybe.monad + [process/env (ffi.constant Object [process env])] + (array.read (:as Nat name) + (:as (Array Text) process/env))) + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..unknown_environment_variable [name])) + (exception.throw ..unknown_environment_variable [name]))) + @.python (!fetch os/environ::get) + @.lua (!fetch os/getenv) + @.ruby (!fetch RubyEnv::fetch) + })))) + + (def: home + (io.run + (with_expansions [<default> (io.io "~") + <jvm> (io.io (maybe.default "" (java/lang/System::getProperty "user.home")))] + (for {@.old <jvm> + @.jvm <jvm> + @.js (if ffi.on_node_js? + (|> (..require [] "os") + (:as NodeJs_OS) + (NodeJs_OS::homedir [])) + <default>) + @.python (os/path::expanduser ["~"]) + @.lua (..run_command "~" "echo ~") + @.ruby (io.io (RubyDir::home)) + ## @.php (do io.monad + ## [output (..getenv/1 ["HOME"])] + ## (wrap (if (bit\= false (:as Bit output)) + ## "~" + ## output))) + } + ## TODO: Replace dummy implementation. + <default>)))) + + (def: directory + (io.run + (with_expansions [<default> "." + <jvm> (io.io (maybe.default "" (java/lang/System::getProperty "user.dir")))] + (for {@.old <jvm> + @.jvm <jvm> + @.js (if ffi.on_node_js? + (case (ffi.constant ..NodeJs_Process [process]) + (#.Some process) + (NodeJs_Process::cwd [] process) + + #.None + (io.io <default>)) + (io.io <default>)) + @.python (os::getcwd []) + @.lua (do io.monad + [#let [default <default>] + on_windows (..run_command default "cd")] + (if (is? default on_windows) + (..run_command default "pwd") + (wrap on_windows))) + @.ruby (io.io (RubyFileUtils::pwd)) + ## @.php (do io.monad + ## [output (..getcwd [])] + ## (wrap (if (bit\= false (:as Bit output)) + ## "." + ## output))) + } + ## TODO: Replace dummy implementation. + (io.io <default>))))) + + (def: (exit code) + (with_expansions [<jvm> (do io.monad + [_ (java/lang/System::exit code)] + (wrap (undefined)))] + (for {@.old <jvm> + @.jvm <jvm> + @.js (cond ffi.on_node_js? + (..exit_node_js! code) + + ffi.on_browser? + (..exit_browser! code) + + ## else + (..default_exit! code)) + @.python (os::_exit [code]) + @.lua (os/exit [code]) + @.ruby (RubyKernel::exit [code]) + ## @.php (..exit [code]) + ## @.scheme (..exit [code]) + })))) diff --git a/stdlib/source/library/lux/world/service/authentication.lux b/stdlib/source/library/lux/world/service/authentication.lux new file mode 100644 index 000000000..4c66ddc1c --- /dev/null +++ b/stdlib/source/library/lux/world/service/authentication.lux @@ -0,0 +1,25 @@ +(.module: + [library + [lux #* + [control + [try (#+ Try)] + [security + [capability (#+ Capability)]]]]]) + +(type: #export (Can-Register ! account secret value) + (Capability [account secret value] (! (Try Any)))) + +(type: #export (Can-Authenticate ! account secret value) + (Capability [account secret] (! (Try value)))) + +(type: #export (Can-Reset ! account secret) + (Capability [account secret] (! (Try Any)))) + +(type: #export (Can-Forget ! account) + (Capability [account] (! (Try Any)))) + +(type: #export (Service ! account secret value) + {#can-register (Can-Register ! account secret value) + #can-authenticate (Can-Authenticate ! account secret value) + #can-reset (Can-Reset ! account secret) + #can-forget (Can-Forget ! account)}) diff --git a/stdlib/source/library/lux/world/service/crud.lux b/stdlib/source/library/lux/world/service/crud.lux new file mode 100644 index 000000000..bd47744f4 --- /dev/null +++ b/stdlib/source/library/lux/world/service/crud.lux @@ -0,0 +1,33 @@ +(.module: + [library + [lux #* + [control + ["." try (#+ Try)] + [security + ["!" capability (#+ capability:)]]] + [time + ["." instant (#+ Instant)]]]]) + +(type: #export ID Nat) + +(type: #export Time + {#created Instant + #updated Instant}) + +(capability: #export (Can-Create ! entity) + (can-create [Instant entity] (! (Try ID)))) + +(capability: #export (Can-Retrieve ! entity) + (can-retrieve ID (! (Try [Time entity])))) + +(capability: #export (Can-Update ! entity) + (can-update [ID Instant entity] (! (Try Any)))) + +(capability: #export (Can-Delete ! entity) + (can-delete ID (! (Try Any)))) + +(type: #export (CRUD ! entity) + {#can-create (Can-Create ! entity) + #can-retrieve (Can-Retrieve ! entity) + #can-update (Can-Update ! entity) + #can-delete (Can-Delete ! entity)}) diff --git a/stdlib/source/library/lux/world/service/inventory.lux b/stdlib/source/library/lux/world/service/inventory.lux new file mode 100644 index 000000000..b6f023075 --- /dev/null +++ b/stdlib/source/library/lux/world/service/inventory.lux @@ -0,0 +1,31 @@ +(.module: + [library + [lux #* + [control + [try (#+ Try)] + [security + ["!" capability (#+ capability:)]]]]]) + +(type: #export ID Nat) + +(type: #export Ownership + {#owner ID + #property ID}) + +(capability: #export (Can-Own !) + (can-own Ownership (! (Try Any)))) + +(capability: #export (Can-Disown !) + (can-disown Ownership (! (Try Any)))) + +(capability: #export (Can-Check !) + (can-check Ownership (! (Try Bit)))) + +(capability: #export (Can-List-Property !) + (can-list-property ID (! (Try (List ID))))) + +(type: #export (Inventory !) + {#can-own (Can-Own !) + #can-disown (Can-Disown !) + #can-check (Can-Check !) + #can-list-property (Can-List-Property !)}) diff --git a/stdlib/source/library/lux/world/service/journal.lux b/stdlib/source/library/lux/world/service/journal.lux new file mode 100644 index 000000000..ba42af209 --- /dev/null +++ b/stdlib/source/library/lux/world/service/journal.lux @@ -0,0 +1,51 @@ +(.module: + [library + [lux #* + [control + [equivalence (#+ Equivalence)] + [interval (#+ Interval)] + [try (#+ Try)] + [security + ["!" capability (#+ capability:)]]] + [data + ["." text ("#\." equivalence)]] + [time + ["." instant (#+ Instant) ("#\." equivalence)]]]]) + +(type: #export (Entry a) + {#what a + #why Text + #how Text + #who Text + #where Text + #when Instant}) + +(type: #export Range + (Interval Instant)) + +(def: #export (range start end) + (-> Instant Instant Range) + (implementation + (def: &enum instant.enum) + (def: bottom start) + (def: top end))) + +(implementation: #export (equivalence (^open "_\.")) + (All [a] (-> (Equivalence a) (Equivalence (Entry a)))) + (def: (= reference sample) + (and (_\= (get@ #what reference) (get@ #what sample)) + (text\= (get@ #why reference) (get@ #why sample)) + (text\= (get@ #how reference) (get@ #how sample)) + (text\= (get@ #who reference) (get@ #who sample)) + (text\= (get@ #where reference) (get@ #where sample)) + (instant\= (get@ #when reference) (get@ #when sample))))) + +(capability: #export (Can-Write ! a) + (can-write (Entry a) (! (Try Any)))) + +(capability: #export (Can-Read ! a) + (can-read Range (! (Try (List (Entry a)))))) + +(type: #export (Journal ! a) + {#can-write (Can-Write ! a) + #can-read (Can-Read ! a)}) diff --git a/stdlib/source/library/lux/world/service/mail.lux b/stdlib/source/library/lux/world/service/mail.lux new file mode 100644 index 000000000..2b2cc9dd1 --- /dev/null +++ b/stdlib/source/library/lux/world/service/mail.lux @@ -0,0 +1,19 @@ +(.module: + [library + [lux #* + [control + [try (#+ Try)] + [concurrency + [frp (#+ Channel)]] + [security + ["!" capability (#+ capability:)]]]]]) + +(capability: #export (Can-Send ! address message) + (can-send [address message] (! (Try Any)))) + +(capability: #export (Can-Subscribe ! address message) + (can-subscribe [address] (! (Try (Channel message))))) + +(type: #export (Service ! address message) + {#can-send (Can-Send ! address message) + #can-subscribe (Can-Subscribe ! address message)}) diff --git a/stdlib/source/library/lux/world/shell.lux b/stdlib/source/library/lux/world/shell.lux new file mode 100644 index 000000000..52cd3efd4 --- /dev/null +++ b/stdlib/source/library/lux/world/shell.lux @@ -0,0 +1,374 @@ +(.module: + [library + [lux #* + ["@" target] + ["jvm" ffi (#+ import:)] + [abstract + [monad (#+ do)]] + [control + ["." function] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["." io (#+ IO)] + [security + ["?" policy (#+ Context Safety Safe)]] + [concurrency + ["." atom (#+ Atom)] + ["." promise (#+ Promise)]] + [parser + [environment (#+ Environment)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." array (#+ Array)] + ["." list ("#\." fold functor)] + ["." dictionary]]] + [math + [number (#+ hex) + ["n" nat]]]]] + [// + [file (#+ Path)]]) + +(type: #export Exit + Int) + +(template [<code> <name>] + [(def: #export <name> + Exit + <code>)] + + [+0 normal] + [+1 error] + ) + +(interface: #export (Process !) + (: (-> [] (! (Try Text))) + read) + (: (-> [] (! (Try Text))) + error) + (: (-> Text (! (Try Any))) + write) + (: (-> [] (! (Try Any))) + destroy) + (: (-> [] (! (Try Exit))) + await)) + +(def: (async_process process) + (-> (Process IO) (Process Promise)) + (`` (implementation + (~~ (template [<method>] + [(def: <method> + (|>> (\ process <method>) + promise.future))] + + [read] + [error] + [write] + [destroy] + [await] + ))))) + +(type: #export Command + Text) + +(type: #export Argument + Text) + +(interface: #export (Shell !) + (: (-> [Environment Path Command (List Argument)] (! (Try (Process !)))) + execute)) + +(def: #export (async shell) + (-> (Shell IO) (Shell Promise)) + (implementation + (def: (execute input) + (promise.future + (do (try.with io.monad) + [process (\ shell execute input)] + (wrap (..async_process process))))))) + +## https://en.wikipedia.org/wiki/Code_injection#Shell_injection +(interface: (Policy ?) + (: (-> Command (Safe Command ?)) + command) + (: (-> Argument (Safe Argument ?)) + argument) + (: (All [a] (-> (Safe a ?) a)) + value)) + +(type: (Sanitizer a) + (-> a a)) + +(type: Replacer + (-> Text Text)) + +(def: (replace bad replacer) + (-> Text Replacer (-> Text Text)) + (text.replace_all bad (replacer bad))) + +(def: sanitize_common_command + (-> Replacer (Sanitizer Command)) + (let [x0A (text.from_code (hex "0A")) + xFF (text.from_code (hex "FF"))] + (function (_ replacer) + (|>> (..replace x0A replacer) + (..replace xFF replacer) + (..replace "\" replacer) + (..replace "&" replacer) + (..replace "#" replacer) + (..replace ";" replacer) + (..replace "`" replacer) + (..replace "|" replacer) + (..replace "*" replacer) + (..replace "?" replacer) + (..replace "~" replacer) + (..replace "^" replacer) + (..replace "$" replacer) + (..replace "<" replacer) (..replace ">" replacer) + (..replace "(" replacer) (..replace ")" replacer) + (..replace "[" replacer) (..replace "]" replacer) + (..replace "{" replacer) (..replace "}" replacer))))) + +(def: (policy sanitize_command sanitize_argument) + (Ex [?] (-> (Sanitizer Command) (Sanitizer Argument) (Policy ?))) + (?.with_policy + (: (Context Safety Policy) + (function (_ (^open "?\.")) + (implementation + (def: command (|>> sanitize_command ?\can_upgrade)) + (def: argument (|>> sanitize_argument ?\can_upgrade)) + (def: value ?\can_downgrade)))))) + +(def: unix_policy + (let [replacer (: Replacer + (|>> (format "\"))) + sanitize_command (: (Sanitizer Command) + (..sanitize_common_command replacer)) + sanitize_argument (: (Sanitizer Argument) + (|>> (..replace "'" replacer) + (text.enclose' "'")))] + (..policy sanitize_command sanitize_argument))) + +(def: windows_policy + (let [replacer (: Replacer + (function.constant " ")) + sanitize_command (: (Sanitizer Command) + (|>> (..sanitize_common_command replacer) + (..replace "%" replacer) + (..replace "!" replacer))) + sanitize_argument (: (Sanitizer Argument) + (|>> (..replace "%" replacer) + (..replace "!" replacer) + (..replace text.double_quote replacer) + (text.enclose' text.double_quote)))] + (..policy sanitize_command sanitize_argument))) + +(with_expansions [<jvm> (as_is (import: java/lang/String + ["#::." + (toLowerCase [] java/lang/String)]) + + (def: (jvm::arguments_array arguments) + (-> (List Argument) (Array java/lang/String)) + (product.right + (list\fold (function (_ argument [idx output]) + [(inc idx) (jvm.array_write idx + (:as java/lang/String argument) + output)]) + [0 (jvm.array java/lang/String (list.size arguments))] + arguments))) + + (import: (java/util/Map k v) + ["#::." + (put [k v] v)]) + + (def: (jvm::load_environment input target) + (-> Environment + (java/util/Map java/lang/String java/lang/String) + (java/util/Map java/lang/String java/lang/String)) + (list\fold (function (_ [key value] target') + (exec (java/util/Map::put (:as java/lang/String key) + (:as java/lang/String value) + target') + target')) + target + (dictionary.entries input))) + + (import: java/io/Reader + ["#::." + (read [] #io #try int)]) + + (import: java/io/BufferedReader + ["#::." + (new [java/io/Reader]) + (readLine [] #io #try #? java/lang/String)]) + + (import: java/io/InputStream) + + (import: java/io/InputStreamReader + ["#::." + (new [java/io/InputStream])]) + + (import: java/io/OutputStream + ["#::." + (write [[byte]] #io #try void)]) + + (import: java/lang/Process + ["#::." + (getInputStream [] #io #try java/io/InputStream) + (getErrorStream [] #io #try java/io/InputStream) + (getOutputStream [] #io #try java/io/OutputStream) + (destroy [] #io #try void) + (waitFor [] #io #try int)]) + + (exception: #export no_more_output) + + (def: (default_process process) + (-> java/lang/Process (IO (Try (Process IO)))) + (do {! (try.with io.monad)} + [jvm_input (java/lang/Process::getInputStream process) + jvm_error (java/lang/Process::getErrorStream process) + jvm_output (java/lang/Process::getOutputStream process) + #let [jvm_input (|> jvm_input + java/io/InputStreamReader::new + java/io/BufferedReader::new) + jvm_error (|> jvm_error + java/io/InputStreamReader::new + java/io/BufferedReader::new)]] + (wrap (: (Process IO) + (`` (implementation + (~~ (template [<name> <stream>] + [(def: (<name> _) + (do ! + [output (java/io/BufferedReader::readLine <stream>)] + (case output + (#.Some output) + (wrap output) + + #.None + (\ io.monad wrap (exception.throw ..no_more_output [])))))] + + [read jvm_input] + [error jvm_error] + )) + (def: (write message) + (java/io/OutputStream::write (\ utf8.codec encode message) jvm_output)) + (~~ (template [<name> <method>] + [(def: (<name> _) + (<method> process))] + + [destroy java/lang/Process::destroy] + [await java/lang/Process::waitFor] + )))))))) + + (import: java/io/File + ["#::." + (new [java/lang/String])]) + + (import: java/lang/ProcessBuilder + ["#::." + (new [[java/lang/String]]) + (environment [] #try (java/util/Map java/lang/String java/lang/String)) + (directory [java/io/File] java/lang/ProcessBuilder) + (start [] #io #try java/lang/Process)]) + + (import: java/lang/System + ["#::." + (#static getProperty [java/lang/String] #io #try java/lang/String)]) + + ## https://en.wikipedia.org/wiki/Code_injection#Shell_injection + (def: windows? + (IO (Try Bit)) + (\ (try.with io.monad) map + (|>> java/lang/String::toLowerCase (text.starts_with? "windows")) + (java/lang/System::getProperty "os.name"))) + + (implementation: #export default + (Shell IO) + + (def: (execute [environment working_directory command arguments]) + (do {! (try.with io.monad)} + [#let [builder (|> (list& command arguments) + ..jvm::arguments_array + java/lang/ProcessBuilder::new + (java/lang/ProcessBuilder::directory (java/io/File::new working_directory)))] + _ (|> builder + java/lang/ProcessBuilder::environment + (\ try.functor map (..jvm::load_environment environment)) + (\ io.monad wrap)) + process (java/lang/ProcessBuilder::start builder)] + (..default_process process)))) + )] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>)} + (as_is))) + +(interface: #export (Mock s) + (: (-> s (Try [s Text])) + on_read) + (: (-> s (Try [s Text])) + on_error) + (: (-> Text s (Try s)) + on_write) + (: (-> s (Try s)) + on_destroy) + (: (-> s (Try [s Exit])) + on_await)) + +(`` (implementation: (mock_process mock state) + (All [s] (-> (Mock s) (Atom s) (Process IO))) + + (~~ (template [<name> <mock>] + [(def: (<name> _) + (do {! io.monad} + [|state| (atom.read state)] + (case (\ mock <mock> |state|) + (#try.Success [|state| output]) + (do ! + [_ (atom.write |state| state)] + (wrap (#try.Success output))) + + (#try.Failure error) + (wrap (#try.Failure error)))))] + + [read on_read] + [error on_error] + [await on_await] + )) + (def: (write message) + (do {! io.monad} + [|state| (atom.read state)] + (case (\ mock on_write message |state|) + (#try.Success |state|) + (do ! + [_ (atom.write |state| state)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error))))) + (def: (destroy _) + (do {! io.monad} + [|state| (atom.read state)] + (case (\ mock on_destroy |state|) + (#try.Success |state|) + (do ! + [_ (atom.write |state| state)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error))))))) + +(implementation: #export (mock mock init) + (All [s] + (-> (-> [Environment Path Command (List Argument)] + (Try (Mock s))) + s + (Shell IO))) + + (def: (execute input) + (io.io (do try.monad + [mock (mock input)] + (wrap (..mock_process mock (atom.atom init))))))) |