## Basic types (_lux_def Bool (+12 ["lux" "Bool"] (+0 "#Bool" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill boolean values.")] (+0))))) (_lux_def Nat (+12 ["lux" "Nat"] (+0 "#Nat" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Natural numbers (unsigned integers). They start at zero (+0) and extend in the positive direction.")] (+0))))) (_lux_def Int (+12 ["lux" "Int"] (+0 "#Int" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill integer numbers.")] (+0))))) (_lux_def Real (+12 ["lux" "Real"] (+0 "#Real" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill floating-point numbers.")] (+0))))) (_lux_def Deg (+12 ["lux" "Deg"] (+0 "#Deg" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Fractional numbers that live in the interval [0,1). Useful for probability, and other domains that work within that interval.")] (+0))))) (_lux_def Char (+12 ["lux" "Char"] (+0 "#Char" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill character values.")] (+0))))) (_lux_def Text (+12 ["lux" "Text"] (+0 "#Text" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill string values.")] (+0))))) (_lux_def Void (+12 ["lux" "Void"] (+1)) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "An unusual type that possesses no value, and thus cannot be instantiated.")] (+0))))) (_lux_def Unit (+12 ["lux" "Unit"] (+2)) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "An unusual type that only possesses a single value: []")] (+0))))) (_lux_def Ident (+12 ["lux" "Ident"] (+4 Text Text)) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "An identifier. It is used as part of Lux syntax to represent symbols and tags.")] (+0))))) ## (type: (List a) ## #Nil ## (#Cons a (List a))) (_lux_def List (+12 ["lux" "List"] (+9 (+0) (+3 ## "lux;Nil" (+2) ## "lux;Cons" (+4 (+6 +1) (+11 (+6 +0) (+6 +1)))))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "tags"] (+8 (+1 (+6 "Nil") (+1 (+6 "Cons") (+0))))] (+1 [["lux" "type-args"] (+8 (+1 (+6 "a") (+0)))] (+1 [["lux" "doc"] (+6 "A potentially empty list of values.")] (+0))))))) ## (type: (Maybe a) ## #None ## (#Some a)) (_lux_def Maybe (+12 ["lux" "Maybe"] (+9 (+0) (+3 ## "lux;None" (+2) ## "lux;Some" (+6 +1)))) (#Cons [["lux" "type?"] (+0 true)] (#Cons [["lux" "export?"] (+0 true)] (#Cons [["lux" "tags"] (+8 (#Cons (+6 "None") (#Cons (+6 "Some") #Nil)))] (#Cons [["lux" "type-args"] (+8 (#Cons (+6 "a") #Nil))] (#Cons [["lux" "doc"] (+6 "A potentially missing value.")] #Nil)))))) ## (type: #rec Type ## (#HostT Text (List Type)) ## #VoidT ## #UnitT ## (#SumT Type Type) ## (#ProdT Type Type) ## (#FunctionT Type Type) ## (#BoundT Nat) ## (#VarT Nat) ## (#ExT Nat) ## (#UnivQ (List Type) Type) ## (#ExQ (List Type) Type) ## (#AppT Type Type) ## (#NamedT Ident Type) ## ) (_lux_def Type (+12 ["lux" "Type"] (_lux_case (+11 (+6 +0) (+6 +1)) Type (_lux_case (+11 List Type) TypeList (_lux_case (+4 Type Type) TypePair (+11 (+9 (+0) (+3 ## "lux;HostT" (+4 Text TypeList) (+3 ## "lux;VoidT" (+2) (+3 ## "lux;UnitT" (+2) (+3 ## "lux;SumT" TypePair (+3 ## "lux;ProdT" TypePair (+3 ## "lux;FunctionT" TypePair (+3 ## "lux;BoundT" Nat (+3 ## "lux;VarT" Nat (+3 ## "lux;ExT" Nat (+3 ## "lux;UnivQ" (+4 TypeList Type) (+3 ## "lux;ExQ" (+4 TypeList Type) (+3 ## "lux;AppT" TypePair ## "lux;NamedT" (+4 Ident Type)))))))))))))) Void))))) (#Cons [["lux" "type?"] (+0 true)] (#Cons [["lux" "export?"] (+0 true)] (#Cons [["lux" "tags"] (+8 (#Cons (+6 "HostT") (#Cons (+6 "VoidT") (#Cons (+6 "UnitT") (#Cons (+6 "SumT") (#Cons (+6 "ProdT") (#Cons (+6 "FunctionT") (#Cons (+6 "BoundT") (#Cons (+6 "VarT") (#Cons (+6 "ExT") (#Cons (+6 "UnivQ") (#Cons (+6 "ExQ") (#Cons (+6 "AppT") (#Cons (+6 "NamedT") #Nil))))))))))))))] (#Cons [["lux" "doc"] (+6 "This type represents the data-structures that are used to specify types themselves.")] (#Cons [["lux" "type-rec?"] (+0 true)] #Nil)))))) ## (type: Top ## (Ex [a] a)) (_lux_def Top (#NamedT ["lux" "Top"] (#ExQ (+0) (#BoundT +1))) (#Cons [["lux" "type?"] (+0 true)] (#Cons [["lux" "export?"] (+0 true)] (#Cons [["lux" "doc"] (+6 "The type of things whose type does not matter. It can be used to write functions or data-structures that can take, or return, anything.")] #Nil)))) ## (type: Bottom ## (All [a] a)) (_lux_def Bottom (#NamedT ["lux" "Bottom"] (#UnivQ (+0) (#BoundT +1))) (#Cons [["lux" "type?"] (+0 true)] (#Cons [["lux" "export?"] (+0 true)] (#Cons [["lux" "doc"] (+6 "The type of things whose type is unknown or undefined. Useful for expressions that cause errors or other \"extraordinary\" conditions.")] #Nil)))) ## (type: #rec Ann-Value ## (#BoolA Bool) ## (#NatA Nat) ## (#IntA Int) ## (#DegA Deg) ## (#RealA Real) ## (#CharA Char) ## (#TextA Text) ## (#IdentA Ident) ## (#ListA (List Ann-Value)) ## (#DictA (List [Text Ann-Value]))) (_lux_def Ann-Value (#NamedT ["lux" "Ann-Value"] (_lux_case (#AppT (#BoundT +0) (#BoundT +1)) Ann-Value (#AppT (#UnivQ #Nil (#SumT ## #BoolA Bool (#SumT ## #NatA Nat (#SumT ## #IntA Int (#SumT ## #DegA Deg (#SumT ## #RealA Real (#SumT ## #CharA Char (#SumT ## #TextA Text (#SumT ## #IdentA Ident (#SumT ## #ListA (#AppT List Ann-Value) ## #DictA (#AppT List (#ProdT Text Ann-Value))))))))))) ) Void) )) (#Cons [["lux" "type?"] (+0 true)] (#Cons [["lux" "export?"] (+0 true)] (#Cons [["lux" "tags"] (+8 (#Cons (+6 "BoolA") (#Cons (+6 "NatA") (#Cons (+6 "IntA") (#Cons (+6 "DegA") (#Cons (+6 "RealA") (#Cons (+6 "CharA") (#Cons (+6 "TextA") (#Cons (+6 "IdentA") (#Cons (+6 "ListA") (#Cons (+6 "DictA") #Nil)))))))))))] (#Cons [["lux" "type-rec?"] (+0 true)] (#Cons [["lux" "doc"] (+6 "The value of an individual annotation.")] #Nil)))))) ## (type: Anns ## (List [Ident Ann-Value])) (_lux_def Anns (#NamedT ["lux" "Anns"] (#AppT List (#ProdT Ident Ann-Value))) (#Cons [["lux" "type?"] (#BoolA true)] (#Cons [["lux" "export?"] (#BoolA true)] (#Cons [["lux" "doc"] (#TextA "A set of annotations associated with a definition.")] #Nil)))) (_lux_def default-def-meta-exported (_lux_: Anns (#Cons [["lux" "type?"] (#BoolA true)] (#Cons [["lux" "export?"] (#BoolA true)] #Nil))) #Nil) (_lux_def default-def-meta-unexported (_lux_: Anns (#Cons [["lux" "type?"] (#BoolA true)] #Nil)) #Nil) ## (type: Def ## [Type Anns Void]) (_lux_def Def (#NamedT ["lux" "Def"] (#ProdT Type (#ProdT Anns Void))) (#Cons [["lux" "doc"] (#TextA "Represents all the data associated with a definition: its type, its annotations, and its value.")] default-def-meta-exported)) ## (type: (Bindings k v) ## {#counter Nat ## #mappings (List [k v])}) (_lux_def Bindings (#NamedT ["lux" "Bindings"] (#UnivQ #Nil (#UnivQ #Nil (#ProdT ## "lux;counter" Nat ## "lux;mappings" (#AppT List (#ProdT (#BoundT +3) (#BoundT +1))))))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "counter") (#Cons (#TextA "mappings") #Nil)))] (#Cons [["lux" "type-args"] (#ListA (#Cons (#TextA "k") (#Cons (#TextA "v") #;Nil)))] default-def-meta-exported))) ## (type: Cursor ## {#module Text ## #line Nat ## #column Nat}) (_lux_def Cursor (#NamedT ["lux" "Cursor"] (#ProdT Text (#ProdT Nat Nat))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "module") (#Cons (#TextA "line") (#Cons (#TextA "column") #Nil))))] (#Cons [["lux" "doc"] (#TextA "Cursors are for specifying the location of AST nodes in Lux files during compilation.")] default-def-meta-exported))) ## (type: (Meta m v) ## {#meta m ## #datum v}) (_lux_def Meta (#NamedT ["lux" "Meta"] (#UnivQ #Nil (#UnivQ #Nil (#ProdT (#BoundT +3) (#BoundT +1))))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "meta") (#Cons (#TextA "datum") #Nil)))] (#Cons [["lux" "doc"] (#TextA "The type of things that can have meta-data of arbitrary types.")] (#Cons [["lux" "type-args"] (#ListA (#Cons (#TextA "m") (#Cons (#TextA "v") #;Nil)))] default-def-meta-exported)))) (_lux_def Analysis (#NamedT ["lux" "Analysis"] (#AppT (#AppT Meta (#ProdT Type Cursor)) Void)) default-def-meta-exported) ## (type: Scope ## {#name (List Text) ## #inner-closures Int ## #locals (Bindings Text Analysis) ## #closure (Bindings Text Analysis)}) (_lux_def Scope (#NamedT ["lux" "Scope"] (#ProdT ## "lux;name" (#AppT List Text) (#ProdT ## "lux;inner-closures" Int (#ProdT ## "lux;locals" (#AppT (#AppT Bindings Text) Analysis) ## "lux;closure" (#AppT (#AppT Bindings Text) Analysis))))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "name") (#Cons (#TextA "inner-closures") (#Cons (#TextA "locals") (#Cons (#TextA "closure") #Nil)))))] default-def-meta-exported)) ## (type: (AST' w) ## (#BoolS Bool) ## (#NatS Nat) ## (#IntS Int) ## (#DegS Deg) ## (#RealS Real) ## (#CharS Char) ## (#TextS Text) ## (#SymbolS Text Text) ## (#TagS Text Text) ## (#FormS (List (w (AST' w)))) ## (#TupleS (List (w (AST' w)))) ## (#RecordS (List [(w (AST' w)) (w (AST' w))]))) (_lux_def AST' (#NamedT ["lux" "AST'"] (_lux_case (#AppT (#BoundT +1) (#AppT (#BoundT +0) (#BoundT +1))) AST (_lux_case (#AppT [List AST]) ASTList (#UnivQ #Nil (#SumT ## "lux;BoolS" Bool (#SumT ## "lux;NatS" Nat (#SumT ## "lux;IntS" Int (#SumT ## "lux;DegS" Deg (#SumT ## "lux;RealS" Real (#SumT ## "lux;CharS" Char (#SumT ## "lux;TextS" Text (#SumT ## "lux;SymbolS" Ident (#SumT ## "lux;TagS" Ident (#SumT ## "lux;FormS" ASTList (#SumT ## "lux;TupleS" ASTList ## "lux;RecordS" (#AppT List (#ProdT AST AST)) ))))))))))) )))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "BoolS") (#Cons (#TextA "NatS") (#Cons (#TextA "IntS") (#Cons (#TextA "DegS") (#Cons (#TextA "RealS") (#Cons (#TextA "CharS") (#Cons (#TextA "TextS") (#Cons (#TextA "SymbolS") (#Cons (#TextA "TagS") (#Cons (#TextA "FormS") (#Cons (#TextA "TupleS") (#Cons (#TextA "RecordS") #Nil)))))))))))))] (#Cons [["lux" "type-args"] (#ListA (#Cons (#TextA "w") #;Nil))] default-def-meta-exported))) ## (type: AST ## (Meta Cursor (AST' (Meta Cursor)))) (_lux_def AST (#NamedT ["lux" "AST"] (_lux_case (#AppT Meta Cursor) w (#AppT w (#AppT AST' w)))) (#Cons [["lux" "doc"] (#TextA "The type of AST nodes for Lux syntax.")] default-def-meta-exported)) (_lux_def ASTList (#AppT List AST) default-def-meta-unexported) ## (type: (Either l r) ## (#Left l) ## (#Right r)) (_lux_def Either (#NamedT ["lux" "Either"] (#UnivQ #Nil (#UnivQ #Nil (#SumT ## "lux;Left" (#BoundT +3) ## "lux;Right" (#BoundT +1))))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "Left") (#Cons (#TextA "Right") #Nil)))] (#Cons [["lux" "type-args"] (#ListA (#Cons (#TextA "l") (#Cons (#TextA "r") #;Nil)))] (#Cons [["lux" "doc"] (#TextA "A choice between two values of different types.")] default-def-meta-exported)))) ## (type: Source ## (List (Meta Cursor Text))) (_lux_def Source (#NamedT ["lux" "Source"] (#AppT [List (#AppT [(#AppT [Meta Cursor]) Text])])) default-def-meta-exported) ## (type: Module-State ## #Active ## #Compiled ## #Cached) (_lux_def Module-State (#NamedT ["lux" "Module-State"] (#SumT ## #Active Unit (#SumT ## #Compiled Unit ## #Cached Unit))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "Active") (#Cons (#TextA "Compiled") (#Cons (#TextA "Cached") #Nil))))] default-def-meta-exported)) ## (type: Module ## {#module-hash Int ## #module-aliases (List [Text Text]) ## #defs (List [Text Def]) ## #imports (List Text) ## #tags (List [Text [Nat (List Ident) Bool Type]]) ## #types (List [Text [(List Ident) Bool Type]])} ## #module-anns Anns ## #module-state Module-State ## ) (_lux_def Module (#NamedT ["lux" "Module"] (#ProdT ## "lux;module-hash" Int (#ProdT ## "lux;module-aliases" (#AppT List (#ProdT Text Text)) (#ProdT ## "lux;defs" (#AppT List (#ProdT Text Def)) (#ProdT ## "lux;imports" (#AppT List Text) (#ProdT ## "lux;tags" (#AppT List (#ProdT Text (#ProdT Nat (#ProdT (#AppT List Ident) (#ProdT Bool Type))))) (#ProdT ## "lux;types" (#AppT List (#ProdT Text (#ProdT (#AppT List Ident) (#ProdT Bool Type)))) (#ProdT ## "lux;module-anns" Anns Module-State)) )))))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "module-hash") (#Cons (#TextA "module-aliases") (#Cons (#TextA "defs") (#Cons (#TextA "imports") (#Cons (#TextA "tags") (#Cons (#TextA "types") (#Cons (#TextA "module-anns") (#Cons (#TextA "module-state") #Nil)))))))))] (#Cons [["lux" "doc"] (#TextA "All the information contained within a Lux module.")] default-def-meta-exported))) ## (type: Compiler-Mode ## #Release ## #Debug ## #Eval ## #REPL) (_lux_def Compiler-Mode (#NamedT ["lux" "Compiler-Mode"] (#SumT ## "lux;Release" #UnitT (#SumT ## "lux;Debug" #UnitT (#SumT ## "lux;Eval" #UnitT ## "lux;REPL" #UnitT)))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "Release") (#Cons (#TextA "Debug") (#Cons (#TextA "Eval") (#Cons (#TextA "REPL") #Nil)))))] (#Cons [["lux" "doc"] (#TextA "A sign that shows the conditions under which the compiler is running.")] default-def-meta-exported))) ## (type: Compiler-Info ## {#compiler-version Text ## #compiler-mode Compiler-Mode}) (_lux_def Compiler-Info (#NamedT ["lux" "Compiler-Info"] (#ProdT ## "lux;compiler-version" Text ## "lux;compiler-mode" Compiler-Mode)) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "compiler-version") (#Cons (#TextA "compiler-mode") #Nil)))] (#Cons [["lux" "doc"] (#TextA "Information about the current version and type of compiler that is running.")] default-def-meta-exported))) ## (type: Compiler ## {#info Compiler-Info ## #source Source ## #cursor Cursor ## #modules (List [Text Module]) ## #scopes (List Scope) ## #type-vars (Bindings Nat (Maybe Type)) ## #expected (Maybe Type) ## #seed Nat ## #scope-type-vars (List Nat) ## #host Void}) (_lux_def Compiler (#NamedT ["lux" "Compiler"] (#ProdT ## "lux;info" Compiler-Info (#ProdT ## "lux;source" Source (#ProdT ## "lux;cursor" Cursor (#ProdT ## "lux;modules" (#AppT List (#ProdT Text Module)) (#ProdT ## "lux;scopes" (#AppT List Scope) (#ProdT ## "lux;type-vars" (#AppT (#AppT Bindings Nat) (#AppT Maybe Type)) (#ProdT ## "lux;expected" (#AppT Maybe Type) (#ProdT ## "lux;seed" Nat (#ProdT ## scope-type-vars (#AppT List Nat) ## "lux;host" Void)))))))))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "info") (#Cons (#TextA "source") (#Cons (#TextA "cursor") (#Cons (#TextA "modules") (#Cons (#TextA "scopes") (#Cons (#TextA "type-vars") (#Cons (#TextA "expected") (#Cons (#TextA "seed") (#Cons (#TextA "scope-type-vars") (#Cons (#TextA "host") #Nil)))))))))))] (#Cons [["lux" "doc"] (#TextA "Represents the state of the Lux compiler during a run. It is provided to macros during their invocation, so they can access compiler data. Caveat emptor: Avoid fiddling with it, unless you know what you're doing.")] default-def-meta-exported))) ## (type: (Lux a) ## (-> Compiler (Either Text [Compiler a]))) (_lux_def Lux (#NamedT ["lux" "Lux"] (#UnivQ #Nil (#FunctionT Compiler (#AppT (#AppT Either Text) (#ProdT Compiler (#BoundT +1)))))) (#Cons [["lux" "doc"] (#TextA "Computations that can have access to the state of the compiler. These computations may fail, or modify the state of the compiler.")] (#Cons [["lux" "type-args"] (#ListA (#Cons (#TextA "a") #;Nil))] default-def-meta-exported))) ## (type: Macro ## (-> (List AST) (Lux (List AST)))) (_lux_def Macro (#NamedT ["lux" "Macro"] (#FunctionT ASTList (#AppT Lux ASTList))) (#Cons [["lux" "doc"] (#TextA "Functions that run at compile-time and allow you to transform and extend the language in powerful ways.")] default-def-meta-exported)) ## Base functions & macros (_lux_def _cursor (_lux_: Cursor ["" +0 +0]) #Nil) (_lux_def _meta (_lux_: (#FunctionT (#AppT AST' (#AppT Meta Cursor)) AST) (_lux_function _ data [_cursor data])) #Nil) (_lux_def return (_lux_: (#UnivQ #Nil (#FunctionT (#BoundT +1) (#FunctionT Compiler (#AppT (#AppT Either Text) (#ProdT Compiler (#BoundT +1)))))) (_lux_function _ val (_lux_function _ state (#Right state val)))) #Nil) (_lux_def fail (_lux_: (#UnivQ #Nil (#FunctionT Text (#FunctionT Compiler (#AppT (#AppT Either Text) (#ProdT Compiler (#BoundT +1)))))) (_lux_function _ msg (_lux_function _ state (#Left msg)))) #Nil) (_lux_def bool$ (_lux_: (#FunctionT Bool AST) (_lux_function _ value (_meta (#BoolS value)))) #Nil) (_lux_def nat$ (_lux_: (#FunctionT Nat AST) (_lux_function _ value (_meta (#NatS value)))) #Nil) (_lux_def int$ (_lux_: (#FunctionT Int AST) (_lux_function _ value (_meta (#IntS value)))) #Nil) (_lux_def deg$ (_lux_: (#FunctionT Deg AST) (_lux_function _ value (_meta (#DegS value)))) #Nil) (_lux_def real$ (_lux_: (#FunctionT Real AST) (_lux_function _ value (_meta (#RealS value)))) #Nil) (_lux_def char$ (_lux_: (#FunctionT Char AST) (_lux_function _ value (_meta (#CharS value)))) #Nil) (_lux_def text$ (_lux_: (#FunctionT Text AST) (_lux_function _ text (_meta (#TextS text)))) #Nil) (_lux_def symbol$ (_lux_: (#FunctionT Ident AST) (_lux_function _ ident (_meta (#SymbolS ident)))) #Nil) (_lux_def tag$ (_lux_: (#FunctionT Ident AST) (_lux_function _ ident (_meta (#TagS ident)))) #Nil) (_lux_def form$ (_lux_: (#FunctionT (#AppT List AST) AST) (_lux_function _ tokens (_meta (#FormS tokens)))) #Nil) (_lux_def tuple$ (_lux_: (#FunctionT (#AppT List AST) AST) (_lux_function _ tokens (_meta (#TupleS tokens)))) #Nil) (_lux_def record$ (_lux_: (#FunctionT (#AppT List (#ProdT AST AST)) AST) (_lux_function _ tokens (_meta (#RecordS tokens)))) #Nil) (_lux_def default-macro-meta (_lux_: Anns (#Cons [["lux" "macro?"] (#BoolA true)] #Nil)) #Nil) (_lux_def let'' (_lux_: Macro (_lux_function _ tokens (_lux_case tokens (#Cons lhs (#Cons rhs (#Cons body #Nil))) (return (#Cons (form$ (#Cons (symbol$ ["" "_lux_case"]) (#Cons rhs (#Cons lhs (#Cons body #Nil))))) #Nil)) _ (fail "Wrong syntax for let''")))) default-macro-meta) (_lux_def function'' (_lux_: Macro (_lux_function _ tokens (_lux_case tokens (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_function")) (#Cons (_meta (#SymbolS "" "")) (#Cons arg (#Cons (_lux_case args' #Nil body _ (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "function''")) (#Cons (_meta (#TupleS args')) (#Cons body #Nil)))))) #Nil)))))) #Nil)) (#Cons [_ (#SymbolS "" self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_function")) (#Cons (_meta (#SymbolS "" self)) (#Cons arg (#Cons (_lux_case args' #Nil body _ (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "function''")) (#Cons (_meta (#TupleS args')) (#Cons body #Nil)))))) #Nil)))))) #Nil)) _ (fail "Wrong syntax for function''")))) default-macro-meta) (_lux_def export?-meta (_lux_: AST (tuple$ (#Cons [(tuple$ (#Cons [(text$ "lux") (#Cons [(text$ "export?") #Nil])])) (#Cons [(form$ (#Cons [(tag$ ["lux" "BoolA"]) (#Cons [(bool$ true) #Nil])])) #Nil])]))) #Nil) (_lux_def hidden?-meta (_lux_: AST (tuple$ (#Cons [(tuple$ (#Cons [(text$ "lux") (#Cons [(text$ "hidden?") #Nil])])) (#Cons [(form$ (#Cons [(tag$ ["lux" "BoolA"]) (#Cons [(bool$ true) #Nil])])) #Nil])]))) #Nil) (_lux_def macro?-meta (_lux_: AST (tuple$ (#Cons [(tuple$ (#Cons [(text$ "lux") (#Cons [(text$ "macro?") #Nil])])) (#Cons [(form$ (#Cons [(tag$ ["lux" "BoolA"]) (#Cons [(bool$ true) #Nil])])) #Nil])]))) #Nil) (_lux_def with-export-meta (_lux_: (#FunctionT AST AST) (function'' [tail] (form$ (#Cons (tag$ ["lux" "Cons"]) (#Cons export?-meta (#Cons tail #Nil)))))) #Nil) (_lux_def with-hidden-meta (_lux_: (#FunctionT AST AST) (function'' [tail] (form$ (#Cons (tag$ ["lux" "Cons"]) (#Cons hidden?-meta (#Cons tail #Nil)))))) #Nil) (_lux_def with-macro-meta (_lux_: (#FunctionT AST AST) (function'' [tail] (form$ (#Cons (tag$ ["lux" "Cons"]) (#Cons macro?-meta (#Cons tail #Nil)))))) #Nil) (_lux_def def:'' (_lux_: Macro (function'' [tokens] (_lux_case tokens (#Cons [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) (#Cons [type (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "function''"])) (#Cons [name (#Cons [(_meta (#TupleS args)) (#Cons [body #Nil])])])]))) #Nil])])]))) (#Cons (with-export-meta meta) #Nil)])])]))) #Nil])) (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) (#Cons [type (#Cons [body #Nil])])]))) (#Cons (with-export-meta meta) #Nil)])])]))) #Nil])) (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) (#Cons [type (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "function''"])) (#Cons [name (#Cons [(_meta (#TupleS args)) (#Cons [body #Nil])])])]))) #Nil])])]))) (#Cons meta #Nil)])])]))) #Nil])) (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) (#Cons [type (#Cons [body #Nil])])]))) (#Cons meta #Nil)])])]))) #Nil])) _ (fail "Wrong syntax for def''")) )) default-macro-meta) (def:'' (macro:' tokens) default-macro-meta Macro (_lux_case tokens (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil)) (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"]) (#Cons (form$ (#Cons name args)) (#Cons (with-macro-meta (tag$ ["lux" "Nil"])) (#Cons (symbol$ ["lux" "Macro"]) (#Cons body #Nil))) ))) #Nil)) (#Cons [_ (#TagS ["" "export"])] (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil))) (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"]) (#Cons (tag$ ["" "export"]) (#Cons (form$ (#Cons name args)) (#Cons (with-macro-meta (tag$ ["lux" "Nil"])) (#Cons (symbol$ ["lux" "Macro"]) (#Cons body #Nil))) )))) #Nil)) (#Cons [_ (#TagS ["" "export"])] (#Cons [_ (#FormS (#Cons name args))] (#Cons meta-data (#Cons body #Nil)))) (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"]) (#Cons (tag$ ["" "export"]) (#Cons (form$ (#Cons name args)) (#Cons (with-macro-meta meta-data) (#Cons (symbol$ ["lux" "Macro"]) (#Cons body #Nil))) )))) #Nil)) _ (fail "Wrong syntax for macro:'"))) (macro:' #export (comment tokens) (#Cons [["lux" "doc"] (#TextA "## Throws away any code given to it. ## Great for commenting-out code, while retaining syntax high-lighting and formatting in your text editor. (comment 1 2 3 4)")] #;Nil) (return #Nil)) (macro:' ($' tokens) (_lux_case tokens (#Cons x #Nil) (return tokens) (#Cons x (#Cons y xs)) (return (#Cons (form$ (#Cons (symbol$ ["lux" "$'"]) (#Cons (form$ (#Cons (tag$ ["lux" "AppT"]) (#Cons x (#Cons y #Nil)))) xs))) #Nil)) _ (fail "Wrong syntax for $'"))) (def:'' (map f xs) #Nil (#UnivQ #Nil (#UnivQ #Nil (#FunctionT (#FunctionT (#BoundT +3) (#BoundT +1)) (#FunctionT ($' List (#BoundT +3)) ($' List (#BoundT +1)))))) (_lux_case xs #Nil #Nil (#Cons x xs') (#Cons (f x) (map f xs')))) (def:'' RepEnv #Nil Type ($' List (#ProdT Text AST))) (def:'' (make-env xs ys) #Nil (#FunctionT ($' List Text) (#FunctionT ($' List AST) RepEnv)) (_lux_case [xs ys] [(#Cons x xs') (#Cons y ys')] (#Cons [x y] (make-env xs' ys')) _ #Nil)) (def:'' (Text/= x y) #Nil (#FunctionT Text (#FunctionT Text Bool)) (_lux_proc ["text" "="] [x y])) (def:'' (get-rep key env) #Nil (#FunctionT Text (#FunctionT RepEnv ($' Maybe AST))) (_lux_case env #Nil #None (#Cons [k v] env') (_lux_case (Text/= k key) true (#Some v) false (get-rep key env')))) (def:'' (replace-syntax reps syntax) #Nil (#FunctionT RepEnv (#FunctionT AST AST)) (_lux_case syntax [_ (#SymbolS "" name)] (_lux_case (get-rep name reps) (#Some replacement) replacement #None syntax) [meta (#FormS parts)] [meta (#FormS (map (replace-syntax reps) parts))] [meta (#TupleS members)] [meta (#TupleS (map (replace-syntax reps) members))] [meta (#RecordS slots)] [meta (#RecordS (map (_lux_: (#FunctionT (#ProdT AST AST) (#ProdT AST AST)) (function'' [slot] (_lux_case slot [k v] [(replace-syntax reps k) (replace-syntax reps v)]))) slots))] _ syntax) ) (def:'' (update-bounds ast) #Nil (#FunctionT AST AST) (_lux_case ast [_ (#TupleS members)] (tuple$ (map update-bounds members)) [_ (#RecordS pairs)] (record$ (map (_lux_: (#FunctionT (#ProdT AST AST) (#ProdT AST AST)) (function'' [pair] (let'' [name val] pair [name (update-bounds val)]))) pairs)) [_ (#FormS (#Cons [_ (#TagS "lux" "BoundT")] (#Cons [_ (#NatS idx)] #Nil)))] (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (nat$ (_lux_proc ["nat" "+"] [+2 idx])) #Nil))) [_ (#FormS members)] (form$ (map update-bounds members)) _ ast)) (def:'' (parse-quantified-args args next) #Nil ## (-> (List AST) (-> (List Text) (Lux (List AST))) (Lux (List AST))) (#FunctionT ($' List AST) (#FunctionT (#FunctionT ($' List Text) (#AppT Lux ($' List AST))) (#AppT Lux ($' List AST)) )) (_lux_case args #Nil (next #Nil) (#Cons [_ (#SymbolS "" arg-name)] args') (parse-quantified-args args' (function'' [names] (next (#Cons arg-name names)))) _ (fail "Expected symbol.") )) (def:'' (make-bound idx) #Nil (#FunctionT Nat AST) (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (nat$ idx) #Nil)))) (def:'' (fold f init xs) #Nil ## (All [a b] (-> (-> b a a) a (List b) a)) (#UnivQ #Nil (#UnivQ #Nil (#FunctionT (#FunctionT (#BoundT +1) (#FunctionT (#BoundT +3) (#BoundT +3))) (#FunctionT (#BoundT +3) (#FunctionT ($' List (#BoundT +1)) (#BoundT +3)))))) (_lux_case xs #Nil init (#Cons x xs') (fold f (f x init) xs'))) (def:'' (length list) #Nil (#UnivQ #Nil (#FunctionT ($' List (#BoundT +1)) Int)) (fold (function'' [_ acc] (_lux_proc ["int" "+"] [1 acc])) 0 list)) (macro:' #export (All tokens) (#Cons [["lux" "doc"] (#TextA "## Universal quantification. (All [a] (-> a a)) ## A name can be provided, to specify a recursive type. (All List [a] (| Unit [a (List a)]))")] #;Nil) (let'' [self-name tokens] (_lux_case tokens (#Cons [_ (#SymbolS "" self-name)] tokens) [self-name tokens] _ ["" tokens]) (_lux_case tokens (#Cons [_ (#TupleS args)] (#Cons body #Nil)) (parse-quantified-args args (function'' [names] (let'' body' (fold (_lux_: (#FunctionT Text (#FunctionT AST AST)) (function'' [name' body'] (form$ (#Cons (tag$ ["lux" "UnivQ"]) (#Cons (tag$ ["lux" "Nil"]) (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) (update-bounds body')) #Nil)))))) body names) (return (#Cons (_lux_case [(Text/= "" self-name) names] [true _] body' [_ #;Nil] body' [false _] (replace-syntax (#Cons [self-name (make-bound (_lux_proc ["nat" "*"] [+2 (_lux_proc ["nat" "-"] [(_lux_proc ["int" "to-nat"] [(length names)]) +1])]))] #Nil) body')) #Nil))))) _ (fail "Wrong syntax for All")) )) (macro:' #export (Ex tokens) (#Cons [["lux" "doc"] (#TextA "## Existential quantification. (Ex [a] [(Codec Text a) a]) ## A name can be provided, to specify a recursive type. (Ex Self [a] [(Codec Text a) a (List (Self a))])")] #;Nil) (let'' [self-name tokens] (_lux_case tokens (#Cons [_ (#SymbolS "" self-name)] tokens) [self-name tokens] _ ["" tokens]) (_lux_case tokens (#Cons [_ (#TupleS args)] (#Cons body #Nil)) (parse-quantified-args args (function'' [names] (let'' body' (fold (_lux_: (#FunctionT Text (#FunctionT AST AST)) (function'' [name' body'] (form$ (#Cons (tag$ ["lux" "ExQ"]) (#Cons (tag$ ["lux" "Nil"]) (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) (update-bounds body')) #Nil)))))) body names) (return (#Cons (_lux_case [(Text/= "" self-name) names] [true _] body' [_ #;Nil] body' [false _] (replace-syntax (#Cons [self-name (make-bound (_lux_proc ["nat" "*"] [+2 (_lux_proc ["nat" "-"] [(_lux_proc ["int" "to-nat"] [(length names)]) +1])]))] #Nil) body')) #Nil))))) _ (fail "Wrong syntax for Ex")) )) (def:'' (reverse list) #Nil (All [a] (#FunctionT ($' List a) ($' List a))) (fold (function'' [head tail] (#Cons head tail)) #Nil list)) (macro:' #export (-> tokens) (#Cons [["lux" "doc"] (#TextA "## Function types: (-> Int Int Int) ## This is the type of a function that takes 2 Ints and returns an Int.")] #;Nil) (_lux_case (reverse tokens) (#Cons output inputs) (return (#Cons (fold (_lux_: (#FunctionT AST (#FunctionT AST AST)) (function'' [i o] (form$ (#Cons (tag$ ["lux" "FunctionT"]) (#Cons i (#Cons o #Nil)))))) output inputs) #Nil)) _ (fail "Wrong syntax for ->"))) (macro:' #export (list xs) (#Cons [["lux" "doc"] (#TextA "## List-construction macro. (list 1 2 3)")] #;Nil) (return (#Cons (fold (function'' [head tail] (form$ (#Cons (tag$ ["lux" "Cons"]) (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) #Nil)))) (tag$ ["lux" "Nil"]) (reverse xs)) #Nil))) (macro:' #export (list& xs) (#Cons [["lux" "doc"] (#TextA "## List-construction macro, with the last element being a tail-list. ## In other words, this macro prepends elements to another list. (list& 1 2 3 (list 4 5 6))")] #;Nil) (_lux_case (reverse xs) (#Cons last init) (return (list (fold (function'' [head tail] (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list head tail))))) last init))) _ (fail "Wrong syntax for list&"))) (macro:' #export (& tokens) (#Cons [["lux" "doc"] (#TextA "## Tuple types: (& Text Int Bool) ## The empty tuple, a.k.a. Unit. (&)")] #;Nil) (_lux_case (reverse tokens) #Nil (return (list (tag$ ["lux" "UnitT"]))) (#Cons last prevs) (return (list (fold (function'' [left right] (form$ (list (tag$ ["lux" "ProdT"]) left right))) last prevs))) )) (macro:' #export (| tokens) (#Cons [["lux" "doc"] (#TextA "## Variant types: (| Text Int Bool) ## The empty tuple, a.k.a. Void. (|)")] #;Nil) (_lux_case (reverse tokens) #Nil (return (list (tag$ ["lux" "VoidT"]))) (#Cons last prevs) (return (list (fold (function'' [left right] (form$ (list (tag$ ["lux" "SumT"]) left right))) last prevs))) )) (macro:' (function' tokens) (let'' [name tokens'] (_lux_case tokens (#Cons [[_ (#SymbolS ["" name])] tokens']) [name tokens'] _ ["" tokens]) (_lux_case tokens' (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) (_lux_case args #Nil (fail "function' requires a non-empty arguments tuple.") (#Cons [harg targs]) (return (list (form$ (list (symbol$ ["" "_lux_function"]) (symbol$ ["" name]) harg (fold (function'' [arg body'] (form$ (list (symbol$ ["" "_lux_function"]) (symbol$ ["" ""]) arg body'))) body (reverse targs))))))) _ (fail "Wrong syntax for function'")))) (macro:' (def:''' tokens) (_lux_case tokens (#Cons [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name (form$ (list (symbol$ ["" "_lux_:"]) type (form$ (list (symbol$ ["lux" "function'"]) name (tuple$ args) body)))) (with-export-meta meta))))) (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name (form$ (list (symbol$ ["" "_lux_:"]) type body)) (with-export-meta meta))))) (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name (form$ (list (symbol$ ["" "_lux_:"]) type (form$ (list (symbol$ ["lux" "function'"]) name (tuple$ args) body)))) meta)))) (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name (form$ (list (symbol$ ["" "_lux_:"]) type body)) meta)))) _ (fail "Wrong syntax for def'''") )) (def:''' (as-pairs xs) #Nil (All [a] (-> ($' List a) ($' List (& a a)))) (_lux_case xs (#Cons x (#Cons y xs')) (#Cons [x y] (as-pairs xs')) _ #Nil)) (macro:' (let' tokens) (_lux_case tokens (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) (return (list (fold (_lux_: (-> (& AST AST) AST AST) (function' [binding body] (_lux_case binding [label value] (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) body (reverse (as-pairs bindings))))) _ (fail "Wrong syntax for let'"))) (def:''' (any? p xs) #Nil (All [a] (-> (-> a Bool) ($' List a) Bool)) (_lux_case xs #Nil false (#Cons x xs') (_lux_case (p x) true true false (any? p xs')))) (def:''' (spliced? token) #Nil (-> AST Bool) (_lux_case token [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))] true _ false)) (def:''' (wrap-meta content) #Nil (-> AST AST) (tuple$ (list (tuple$ (list (text$ "") (nat$ +0) (nat$ +0))) content))) (def:''' (untemplate-list tokens) #Nil (-> ($' List AST) AST) (_lux_case tokens #Nil (_meta (#TagS ["lux" "Nil"])) (#Cons [token tokens']) (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) token (untemplate-list tokens')))))) (def:''' (List/append xs ys) #Nil (All [a] (-> ($' List a) ($' List a) ($' List a))) (_lux_case xs (#Cons x xs') (#Cons x (List/append xs' ys)) #Nil ys)) (def:''' #export (splice-helper xs ys) (#Cons [["lux" "hidden?"] (#BoolA true)] #;Nil) (-> ($' List AST) ($' List AST) ($' List AST)) (_lux_case xs (#Cons x xs') (#Cons x (splice-helper xs' ys)) #Nil ys)) (macro:' #export (_$ tokens) (#Cons [["lux" "doc"] (#TextA "## Left-association for the application of binary functions over variadic arguments. (_$ Text/append \"Hello, \" name \".\\nHow are you?\") ## => (Text/append (Text/append \"Hello, \" name) \".\\nHow are you?\")")] #;Nil) (_lux_case tokens (#Cons op tokens') (_lux_case tokens' (#Cons first nexts) (return (list (fold (function' [a1 a2] (form$ (list op a1 a2))) first nexts))) _ (fail "Wrong syntax for _$")) _ (fail "Wrong syntax for _$"))) (macro:' #export ($_ tokens) (#Cons [["lux" "doc"] (#TextA "## Right-association for the application of binary functions over variadic arguments. ($_ Text/append \"Hello, \" name \".\\nHow are you?\") ## => (Text/append \"Hello, \" (Text/append name \".\\nHow are you?\"))")] #;Nil) (_lux_case tokens (#Cons op tokens') (_lux_case (reverse tokens') (#Cons last prevs) (return (list (fold (function' [a1 a2] (form$ (list op a1 a2))) last prevs))) _ (fail "Wrong syntax for $_")) _ (fail "Wrong syntax for $_"))) ## (sig: (Monad m) ## (: (All [a] (-> a (m a))) ## wrap) ## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) ## bind)) (def:''' Monad (list& [["lux" "tags"] (#ListA (list (#TextA "wrap") (#TextA "bind")))] default-def-meta-unexported) Type (#NamedT ["lux" "Monad"] (All [m] (& (All [a] (-> a ($' m a))) (All [a b] (-> (-> a ($' m b)) ($' m a) ($' m b))))))) (def:''' Monad #Nil ($' Monad Maybe) {#wrap (function' [x] (#Some x)) #bind (function' [f ma] (_lux_case ma #None #None (#Some a) (f a)))}) (def:''' Monad #Nil ($' Monad Lux) {#wrap (function' [x] (function' [state] (#Right state x))) #bind (function' [f ma] (function' [state] (_lux_case (ma state) (#Left msg) (#Left msg) (#Right state' a) (f a state'))))}) (macro:' (do tokens) (_lux_case tokens (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) (let' [g!wrap (symbol$ ["" "wrap"]) g!bind (symbol$ ["" " bind "]) body' (fold (_lux_: (-> (& AST AST) AST AST) (function' [binding body'] (let' [[var value] binding] (_lux_case var [_ (#TagS "" "let")] (form$ (list (symbol$ ["lux" "let'"]) value body')) _ (form$ (list g!bind (form$ (list (symbol$ ["" "_lux_function"]) (symbol$ ["" ""]) var body')) value)))))) body (reverse (as-pairs bindings)))] (return (list (form$ (list (symbol$ ["" "_lux_case"]) monad (record$ (list [(tag$ ["lux" "wrap"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) body'))))) _ (fail "Wrong syntax for do"))) (def:''' (mapM 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] (_lux_case xs #Nil (wrap #Nil) (#Cons x xs') (do m [y (f x) ys (mapM m f xs')] (wrap (#Cons y ys))) ))) (macro:' #export (if tokens) (list [["lux" "doc"] (#TextA "Picks which expression to evaluate based on a boolean test value. (if true \"Oh, yeah!\" \"Aw hell naw!\") == \"Oh, yeah!\"")]) (_lux_case tokens (#Cons test (#Cons then (#Cons else #Nil))) (return (list (form$ (list (symbol$ ["" "_lux_case"]) test (bool$ true) then (bool$ false) else)))) _ (fail "Wrong syntax for if"))) (def:''' (get k plist) #Nil (All [a] (-> Text ($' List (& Text a)) ($' Maybe a))) (_lux_case plist (#Cons [[k' v] plist']) (if (Text/= k k') (#Some v) (get k plist')) #Nil #None)) (def:''' (put k v dict) #Nil (All [a] (-> Text a ($' List (& Text a)) ($' List (& Text a)))) (_lux_case dict #Nil (list [k v]) (#Cons [[k' v'] dict']) (if (Text/= k k') (#Cons [[k' v] dict']) (#Cons [[k' v'] (put k v dict')])))) (def:''' #export (log! message) (list [["lux" "doc"] (#TextA "Logs message to standard output. Useful for debugging.")]) (-> Text Unit) (_lux_proc ["io" "log"] [message])) (def:''' (Text/append x y) #Nil (-> Text Text Text) (_lux_proc ["text" "append"] [x y])) (def:''' (Ident/encode ident) #Nil (-> Ident Text) (let' [[module name] ident] (_lux_case module "" name _ ($_ Text/append module ";" name)))) (def:''' (get-meta tag def-meta) #Nil (-> Ident Anns ($' Maybe Ann-Value)) (let' [[prefix name] tag] (_lux_case def-meta (#Cons [[prefix' name'] value] def-meta') (_lux_case [(Text/= prefix prefix') (Text/= name name')] [true true] (#Some value) _ (get-meta tag def-meta')) #Nil #None))) (def:''' (resolve-global-symbol ident state) #Nil (-> Ident ($' Lux Ident)) (let' [[module name] ident {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars} state] (_lux_case (get module modules) (#Some {#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _ #module-state _}) (_lux_case (get name defs) (#Some [def-type def-meta def-value]) (_lux_case (get-meta ["lux" "alias"] def-meta) (#Some (#IdentA real-name)) (#Right [state real-name]) _ (#Right [state ident])) #None (#Left ($_ Text/append "Unknown definition: " (Ident/encode ident)))) #None (#Left ($_ Text/append "Unknown module: " module " @ " (Ident/encode ident)))))) (def:''' (splice replace? untemplate tag elems) #Nil (-> Bool (-> AST ($' Lux AST)) AST ($' List AST) ($' Lux AST)) (_lux_case replace? true (_lux_case (any? spliced? elems) true (do Monad [elems' (_lux_: ($' Lux ($' List AST)) (mapM Monad (_lux_: (-> AST ($' Lux AST)) (function' [elem] (_lux_case elem [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] (wrap spliced) _ (do Monad [=elem (untemplate elem)] (wrap (form$ (list (symbol$ ["" "_lux_:"]) (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "AST"]))))) (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list =elem (tag$ ["lux" "Nil"])))))))))))) elems))] (wrap (wrap-meta (form$ (list tag (form$ (list& (symbol$ ["lux" "$_"]) (symbol$ ["lux" "splice-helper"]) elems'))))))) false (do Monad [=elems (mapM Monad untemplate elems)] (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))) false (do Monad [=elems (mapM Monad untemplate elems)] (wrap (wrap-meta (form$ (list tag (untemplate-list =elems)))))))) (def:''' (untemplate replace? subst token) #Nil (-> Bool Text AST ($' Lux AST)) (_lux_case [replace? token] [_ [_ (#BoolS value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (bool$ value))))) [_ [_ (#NatS value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "NatS"]) (nat$ value))))) [_ [_ (#IntS value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (int$ value))))) [_ [_ (#DegS value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "DegS"]) (deg$ value))))) [_ [_ (#RealS value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (real$ value))))) [_ [_ (#CharS value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (char$ value))))) [_ [_ (#TextS value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (text$ value))))) [false [_ (#TagS [module name])]] (return (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module) (text$ name))))))) [true [_ (#TagS [module name])]] (let' [module' (_lux_case module "" subst _ module)] (return (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name)))))))) [true [_ (#SymbolS [module name])]] (do Monad [real-name (_lux_case module "" (if (Text/= "" subst) (wrap [module name]) (resolve-global-symbol [subst name])) _ (wrap [module name])) #let [[module name] real-name]] (return (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module) (text$ name)))))))) [false [_ (#SymbolS [module name])]] (return (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module) (text$ name))))))) [_ [_ (#TupleS elems)]] (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] (return unquoted) [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~'"])] (#Cons [keep-quoted #Nil])]))]] (untemplate false subst keep-quoted) [_ [meta (#FormS elems)]] (do Monad [output (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) #let [[_ form'] output]] (return [meta form'])) [_ [_ (#RecordS fields)]] (do Monad [=fields (mapM Monad (_lux_: (-> (& AST AST) ($' Lux AST)) (function' [kv] (let' [[k v] kv] (do Monad [=k (untemplate replace? subst k) =v (untemplate replace? subst v)] (wrap (tuple$ (list =k =v))))))) fields)] (wrap (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) (untemplate-list =fields)))))) )) (macro:' #export (host tokens) (list [["lux" "doc"] (#TextA "## Macro to treat host-types as Lux-types. (host java.lang.Object) (host java.util.List [java.lang.Long])")]) (_lux_case tokens (#Cons [_ (#SymbolS "" class-name)] #Nil) (return (list (form$ (list (tag$ ["lux" "HostT"]) (text$ class-name) (tag$ ["lux" "Nil"]))))) (#Cons [_ (#SymbolS "" class-name)] (#Cons [_ (#TupleS params)] #Nil)) (return (list (form$ (list (tag$ ["lux" "HostT"]) (text$ class-name) (untemplate-list params))))) _ (fail "Wrong syntax for host"))) (def:'' (current-module-name state) #Nil ($' Lux Text) (_lux_case state {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars} (_lux_case (reverse scopes) (#Cons {#name (#;Cons module-name #Nil) #inner-closures _ #locals _ #closure _} _) (#Right [state module-name]) _ (#Left "Cannot get the module name without a module!") ))) (macro:' #export (` tokens) (list [["lux" "doc"] (#TextA "## Hygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~@) must also be used as forms. ## 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. (` (def: (~ name) (function [(~@ args)] (~ body))))")]) (_lux_case tokens (#Cons template #Nil) (do Monad [current-module current-module-name =template (untemplate true current-module template)] (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) _ (fail "Wrong syntax for `"))) (macro:' #export (`' tokens) (list [["lux" "doc"] (#TextA "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~@) must also be used as forms. (`' (def: (~ name) (function [(~@ args)] (~ body))))")]) (_lux_case tokens (#Cons template #Nil) (do Monad [=template (untemplate true "" template)] (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) _ (fail "Wrong syntax for `"))) (macro:' #export (' tokens) (list [["lux" "doc"] (#TextA "## Quotation as a macro. (' \"YOLO\")")]) (_lux_case tokens (#Cons template #Nil) (do Monad [=template (untemplate false "" template)] (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) _ (fail "Wrong syntax for '"))) (macro:' #export (|> tokens) (list [["lux" "doc"] (#TextA "## Piping macro. (|> elems (map Int/encode) (interpose \" \") (fold Text/append \"\")) ## => (fold Text/append \"\" (interpose \" \" (map Int/encode elems)))")]) (_lux_case tokens (#Cons [init apps]) (return (list (fold (_lux_: (-> AST AST AST) (function' [app acc] (_lux_case app [_ (#TupleS parts)] (tuple$ (List/append parts (list acc))) [_ (#FormS parts)] (form$ (List/append parts (list acc))) _ (` ((~ app) (~ acc)))))) init apps))) _ (fail "Wrong syntax for |>"))) (macro:' #export (<| tokens) (list [["lux" "doc"] (#TextA "## Reverse piping macro. (<| (fold Text/append \"\") (interpose \" \") (map Int/encode) elems) ## => (fold Text/append \"\" (interpose \" \" (map Int/encode elems)))")]) (_lux_case (reverse tokens) (#Cons [init apps]) (return (list (fold (_lux_: (-> AST AST AST) (function' [app acc] (_lux_case app [_ (#TupleS parts)] (tuple$ (List/append parts (list acc))) [_ (#FormS parts)] (form$ (List/append parts (list acc))) _ (` ((~ app) (~ acc)))))) init apps))) _ (fail "Wrong syntax for <|"))) (def:''' #export (. f g) (list [["lux" "doc"] (#TextA "Function composition.")]) (All [a b c] (-> (-> b c) (-> a b) (-> a c))) (function' [x] (f (g x)))) (def:''' (get-ident x) #Nil (-> AST ($' Maybe Ident)) (_lux_case x [_ (#SymbolS sname)] (#Some sname) _ #None)) (def:''' (get-tag x) #Nil (-> AST ($' Maybe Ident)) (_lux_case x [_ (#TagS sname)] (#Some sname) _ #None)) (def:''' (get-name x) #Nil (-> AST ($' Maybe Text)) (_lux_case x [_ (#SymbolS "" sname)] (#Some sname) _ #None)) (def:''' (tuple->list tuple) #Nil (-> AST ($' Maybe ($' List AST))) (_lux_case tuple [_ (#TupleS members)] (#Some members) _ #None)) (def:''' (apply-template env template) #Nil (-> RepEnv AST AST) (_lux_case template [_ (#SymbolS "" sname)] (_lux_case (get-rep sname env) (#Some subst) subst _ template) [meta (#TupleS elems)] [meta (#TupleS (map (apply-template env) elems))] [meta (#FormS elems)] [meta (#FormS (map (apply-template env) elems))] [meta (#RecordS members)] [meta (#RecordS (map (_lux_: (-> (& AST AST) (& AST AST)) (function' [kv] (let' [[slot value] kv] [(apply-template env slot) (apply-template env value)]))) members))] _ template)) (def:''' (join-map f xs) #Nil (All [a b] (-> (-> a ($' List b)) ($' List a) ($' List b))) (_lux_case xs #Nil #Nil (#Cons [x xs']) (List/append (f x) (join-map f xs')))) (def:''' (every? p xs) #Nil (All [a] (-> (-> a Bool) ($' List a) Bool)) (fold (function' [_2 _1] (if _1 (p _2) false)) true xs)) (macro:' #export (do-template tokens) (list [["lux" "doc"] (#TextA "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary. (do-template [ ] [(def: #export (-> Int Int) (i.+ ))] [i.inc 1] [i.dec -1])")]) (_lux_case tokens (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) (_lux_case [(mapM Monad get-name bindings) (mapM Monad tuple->list data)] [(#Some bindings') (#Some data')] (let' [apply (_lux_: (-> RepEnv ($' List AST)) (function' [env] (map (apply-template env) templates))) num-bindings (length bindings')] (if (every? (function' [sample] (_lux_proc ["int" "="] [num-bindings sample])) (map length data')) (|> data' (join-map (. apply (make-env bindings'))) return) (fail "Irregular arguments vectors for do-template."))) _ (fail "Wrong syntax for do-template")) _ (fail "Wrong syntax for do-template"))) (do-template [ <=-name> <<-doc> <<=-doc> <>-doc> <>=-doc>] [(def:''' #export (<=-name> test subject) (list [["lux" "doc"] (#TextA )]) (-> Bool) (_lux_proc [ "="] [subject test])) (def:''' #export ( test subject) (list [["lux" "doc"] (#TextA <<-doc>)]) (-> Bool) (_lux_proc [ "<"] [subject test])) (def:''' #export ( test subject) (list [["lux" "doc"] (#TextA <<=-doc>)]) (-> Bool) (if (_lux_proc [ "<"] [subject test]) true (_lux_proc [ "="] [subject test]))) (def:''' #export ( test subject) (list [["lux" "doc"] (#TextA <>-doc>)]) (-> Bool) (_lux_proc [ "<"] [test subject])) (def:''' #export ( test subject) (list [["lux" "doc"] (#TextA <>=-doc>)]) (-> Bool) (if (_lux_proc [ "<"] [test subject]) true (_lux_proc [ "="] [subject test])))] [ Nat "nat" n.= n.< n.<= n.> n.>= "Natural equality." "Natural less-than." "Natural less-than-equal." "Natural greater-than." "Natural greater-than-equal."] [ Int "int" i.= i.< i.<= i.> i.>= "Integer equality." "Integer less-than." "Integer less-than-equal." "Integer greater-than." "Integer greater-than-equal."] [ Deg "deg" d.= d.< d.<= d.> d.>= "Degree equality." "Degree less-than." "Degree less-than-equal." "Degree greater-than." "Degree greater-than-equal."] [Real "real" r.= r.< r.<= r.> r.>= "Real equality." "Real less-than." "Real less-than-equal." "Real greater-than." "Real greater-than-equal."] ) (do-template [ ] [(def:''' #export ( param subject) (list [["lux" "doc"] (#TextA )]) (-> ) (_lux_proc [subject param]))] [ Nat n.+ [ "nat" "+"] "Nat(ural) addition."] [ Nat n.- [ "nat" "-"] "Nat(ural) substraction."] [ Nat n.* [ "nat" "*"] "Nat(ural) multiplication."] [ Nat n./ [ "nat" "/"] "Nat(ural) division."] [ Nat n.% [ "nat" "%"] "Nat(ural) remainder."] [ Int i.+ [ "int" "+"] "Int(eger) addition."] [ Int i.- [ "int" "-"] "Int(eger) substraction."] [ Int i.* [ "int" "*"] "Int(eger) multiplication."] [ Int i./ [ "int" "/"] "Int(eger) division."] [ Int i.% [ "int" "%"] "Int(eger) remainder."] [ Deg d.+ [ "deg" "+"] "Deg(ree) addition."] [ Deg d.- [ "deg" "-"] "Deg(ree) substraction."] [ Deg d.* [ "deg" "*"] "Deg(ree) multiplication."] [ Deg d./ [ "deg" "/"] "Deg(ree) division."] [ Deg d.% [ "deg" "%"] "Deg(ree) remainder."] [Real r.+ ["real" "+"] "Real addition."] [Real r.- ["real" "-"] "Real substraction."] [Real r.* ["real" "*"] "Real multiplication."] [Real r./ ["real" "/"] "Real division."] [Real r.% ["real" "%"] "Real remainder."] ) (do-template [ ] [(def:''' #export ( param subject) (list [["lux" "doc"] (#TextA )]) (-> Nat ) (_lux_proc [subject param]))] [ Deg d.scale [ "deg" "scale"] "Deg(ree) scale."] [ Deg d.reciprocal [ "deg" "reciprocal"] "Deg(ree) reciprocal."] ) (do-template [ ] [(def:''' #export ( left right) (list [["lux" "doc"] (#TextA )]) (-> ) (if ( right left) left right))] [n.min Nat n.< "Nat(ural) minimum."] [n.max Nat n.> "Nat(ural) maximum."] [i.min Int i.< "Int(eger) minimum."] [i.max Int i.> "Int(eger) maximum."] [d.min Deg d.< "Deg(ree) minimum."] [d.max Deg d.> "Deg(ree) maximum."] [r.min Real r.< "Real minimum."] [r.max Real r.> "Real minimum."] ) (def:''' (Bool/encode x) #Nil (-> Bool Text) (if x "true" "false")) (def:''' (digit-to-text digit) #Nil (-> Nat Text) (_lux_case digit +0 "0" +1 "1" +2 "2" +3 "3" +4 "4" +5 "5" +6 "6" +7 "7" +8 "8" +9 "9" _ (_lux_proc ["io" "error"] ["undefined"]))) (def:''' (Nat/encode value) #Nil (-> Nat Text) (_lux_case value +0 "+0" _ (let' [loop (_lux_: (-> Nat Text Text) (function' recur [input output] (if (_lux_proc ["nat" "="] [input +0]) (_lux_proc ["text" "append"] ["+" output]) (recur (_lux_proc ["nat" "/"] [input +10]) (_lux_proc ["text" "append"] [(digit-to-text (_lux_proc ["nat" "%"] [input +10])) output])))))] (loop value "")))) (def:''' (Int/abs value) #Nil (-> Int Int) (if (i.< 0 value) (i.* -1 value) value)) (def:''' (Int/encode value) #Nil (-> Int Text) (if (i.= 0 value) "0" (let' [sign (if (i.> 0 value) "" "-")] ((_lux_: (-> Int Text Text) (function' recur [input output] (if (i.= 0 input) (_lux_proc ["text" "append"] [sign output]) (recur (i./ 10 input) (_lux_proc ["text" "append"] [(|> input (i.% 10) (_lux_:! Nat) digit-to-text) output]))))) (|> value (i./ 10) Int/abs) (|> value (i.% 10) Int/abs (_lux_:! Nat) digit-to-text))))) (def:''' (Deg/encode x) #Nil (-> Deg Text) (_lux_proc ["deg" "encode"] [x])) (def:''' (Real/encode x) #Nil (-> Real Text) (_lux_proc ["real" "encode"] [x])) (def:''' (Char/encode x) #Nil (-> Char Text) (let' [as-text (_lux_case x #"\t" "\\t" #"\v" "\\v" #"\b" "\\b" #"\n" "\\n" #"\r" "\\r" #"\f" "\\f" #"\"" "\\\"" #"\\" "\\\\" _ (_lux_proc ["char" "to-text"] [x]))] ($_ Text/append "#\"" as-text "\""))) (def:''' (multiple? div n) #Nil (-> Int Int Bool) (i.= 0 (i.% div n))) (def:''' #export (not x) (list [["lux" "doc"] (#TextA "## Boolean negation. (not true) == false (not false) == true")]) (-> Bool Bool) (if x false true)) (def:''' (find-macro' modules current-module module name) #Nil (-> ($' List (& Text Module)) Text Text Text ($' Maybe Macro)) (do Monad [$module (get module modules) gdef (let' [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _ #module-state _} (_lux_: Module $module)] (get name bindings))] (let' [[def-type def-meta def-value] (_lux_: Def gdef)] (_lux_case (get-meta ["lux" "macro?"] def-meta) (#Some (#BoolA true)) (_lux_case (get-meta ["lux" "export?"] def-meta) (#Some (#BoolA true)) (#Some (_lux_:! Macro def-value)) _ (if (Text/= module current-module) (#Some (_lux_:! Macro def-value)) #None)) _ (_lux_case (get-meta ["lux" "alias"] def-meta) (#Some (#IdentA [r-module r-name])) (find-macro' modules current-module r-module r-name) _ #None) )) )) (def:''' (normalize ident) #Nil (-> Ident ($' Lux Ident)) (_lux_case ident ["" name] (do Monad [module-name current-module-name] (wrap [module-name name])) _ (return ident))) (def:''' (find-macro ident) #Nil (-> Ident ($' Lux ($' Maybe Macro))) (do Monad [current-module current-module-name] (let' [[module name] ident] (function' [state] (_lux_case state {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars} (#Right state (find-macro' modules current-module module name))))))) (def:''' (macro? ident) #Nil (-> Ident ($' Lux Bool)) (do Monad [ident (normalize ident) output (find-macro ident)] (wrap (_lux_case output (#Some _) true #None false)))) (def:''' (List/join xs) #Nil (All [a] (-> ($' List ($' List a)) ($' List a))) (fold List/append #Nil (reverse xs))) (def:''' (interpose sep xs) #Nil (All [a] (-> a ($' List a) ($' List a))) (_lux_case xs #Nil xs (#Cons [x #Nil]) xs (#Cons [x xs']) (list& x sep (interpose sep xs')))) (def:''' (macro-expand-once token) #Nil (-> AST ($' Lux ($' List AST))) (_lux_case token [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] (do Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] (_lux_case ?macro (#Some macro) (macro args) #None (return (list token)))) _ (return (list token)))) (def:''' (macro-expand token) #Nil (-> AST ($' Lux ($' List AST))) (_lux_case token [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] (do Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] (_lux_case ?macro (#Some macro) (do Monad [expansion (macro args) expansion' (mapM Monad macro-expand expansion)] (wrap (List/join expansion'))) #None (return (list token)))) _ (return (list token)))) (def:''' (macro-expand-all syntax) #Nil (-> AST ($' Lux ($' List AST))) (_lux_case syntax [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] (do Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] (_lux_case ?macro (#Some macro) (do Monad [expansion (macro args) expansion' (mapM Monad macro-expand-all expansion)] (wrap (List/join expansion'))) #None (do Monad [args' (mapM Monad macro-expand-all args)] (wrap (list (form$ (#Cons (symbol$ macro-name) (List/join args')))))))) [_ (#FormS members)] (do Monad [members' (mapM Monad macro-expand-all members)] (wrap (list (form$ (List/join members'))))) [_ (#TupleS members)] (do Monad [members' (mapM Monad macro-expand-all members)] (wrap (list (tuple$ (List/join members'))))) [_ (#RecordS pairs)] (do Monad [pairs' (mapM Monad (function' [kv] (let' [[key val] kv] (do Monad [val' (macro-expand-all val)] (_lux_case val' (#;Cons val'' #;Nil) (return [key val'']) _ (fail "The value-part of a KV-pair in a record must macro-expand to a single AST."))))) pairs)] (wrap (list (record$ pairs')))) _ (return (list syntax)))) (def:''' (walk-type type) #Nil (-> AST AST) (_lux_case type [_ (#FormS (#Cons [_ (#TagS tag)] parts))] (form$ (#Cons [(tag$ tag) (map walk-type parts)])) [_ (#TupleS members)] (` (& (~@ (map walk-type members)))) [_ (#FormS (#Cons type-fn args))] (fold (_lux_: (-> AST AST AST) (function' [arg type-fn] (` (#;AppT (~ type-fn) (~ arg))))) (walk-type type-fn) (map walk-type args)) _ type)) (macro:' #export (type tokens) (list [["lux" "doc"] (#TextA "## Takes a type expression and returns it's representation as data-structure. (type (All [a] (Maybe (List a))))")]) (_lux_case tokens (#Cons type #Nil) (do Monad [type+ (macro-expand-all type)] (_lux_case type+ (#Cons type' #Nil) (wrap (list (walk-type type'))) _ (fail "The expansion of the type-syntax had to yield a single element."))) _ (fail "Wrong syntax for type"))) (macro:' #export (: tokens) (list [["lux" "doc"] (#TextA "## The type-annotation macro. (: (List Int) (list 1 2 3))")]) (_lux_case tokens (#Cons type (#Cons value #Nil)) (return (list (` (;_lux_: (type (~ type)) (~ value))))) _ (fail "Wrong syntax for :"))) (macro:' #export (:! tokens) (list [["lux" "doc"] (#TextA "## The type-coercion macro. (:! Dinosaur (list 1 2 3))")]) (_lux_case tokens (#Cons type (#Cons value #Nil)) (return (list (` (;_lux_:! (type (~ type)) (~ value))))) _ (fail "Wrong syntax for :!"))) (def:''' (empty? xs) #Nil (All [a] (-> ($' List a) Bool)) (_lux_case xs #Nil true _ false)) (do-template [ ] [(def:''' ( xy) #Nil (All [a b] (-> (& a b) )) (let' [[x y] xy] ))] [first a x] [second b y]) (def:''' (unfold-type-def type-asts) #Nil (-> ($' List AST) ($' Lux (& AST ($' Maybe ($' List Text))))) (_lux_case type-asts (#Cons [_ (#RecordS pairs)] #;Nil) (do Monad [members (mapM Monad (: (-> [AST AST] (Lux [Text AST])) (function' [pair] (_lux_case pair [[_ (#TagS "" member-name)] member-type] (return [member-name member-type]) _ (fail "Wrong syntax for variant case.")))) pairs)] (return [(` (& (~@ (map second members)))) (#Some (map first members))])) (#Cons type #Nil) (_lux_case type [_ (#TagS "" member-name)] (return [(` #;UnitT) (#;Some (list member-name))]) [_ (#FormS (#Cons [_ (#TagS "" member-name)] member-types))] (return [(` (& (~@ member-types))) (#;Some (list member-name))]) _ (return [type #None])) (#Cons case cases) (do Monad [members (mapM Monad (: (-> AST (Lux [Text AST])) (function' [case] (_lux_case case [_ (#TagS "" member-name)] (return [member-name (` Unit)]) [_ (#FormS (#Cons [_ (#TagS "" member-name)] (#Cons member-type #Nil)))] (return [member-name member-type]) [_ (#FormS (#Cons [_ (#TagS "" member-name)] member-types))] (return [member-name (` (& (~@ member-types)))]) _ (fail "Wrong syntax for variant case.")))) (list& case cases))] (return [(` (| (~@ (map second members)))) (#Some (map first members))])) _ (fail "Improper type-definition syntax"))) (def:''' (gensym prefix state) #Nil (-> Text ($' Lux AST)) (_lux_case state {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars} (#Right {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed (n.+ +1 seed) #expected expected #cursor cursor #scope-type-vars scope-type-vars} (symbol$ ["" ($_ Text/append "__gensym__" prefix (Nat/encode seed))])))) (macro:' #export (Rec tokens) (list [["lux" "doc"] (#TextA "## Parameter-less recursive types. ## A name has to be given to the whole type, to use it within its body. (Rec Self [Int (List Self)])")]) (_lux_case tokens (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil)) (let' [body' (replace-syntax (list [name (` (#AppT (~ (make-bound +0)) (~ (make-bound +1))))]) (update-bounds body))] (return (list (` (#AppT (#UnivQ #Nil (~ body')) Void))))) _ (fail "Wrong syntax for Rec"))) (macro:' #export (exec tokens) (list [["lux" "doc"] (#TextA "## Sequential execution of expressions (great for side-effects). (exec (log! \"#1\") (log! \"#2\") (log! \"#3\") \"YOLO\")")]) (_lux_case (reverse tokens) (#Cons value actions) (let' [dummy (symbol$ ["" ""])] (return (list (fold (_lux_: (-> AST AST AST) (function' [pre post] (` (;_lux_case (~ pre) (~ dummy) (~ post))))) value actions)))) _ (fail "Wrong syntax for exec"))) (macro:' (def:' tokens) (let' [[export? tokens'] (_lux_case tokens (#Cons [_ (#TagS "" "export")] tokens') [true tokens'] _ [false tokens]) parts (: (Maybe [AST (List AST) (Maybe AST) AST]) (_lux_case tokens' (#Cons [_ (#FormS (#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 [_ (#FormS (#Cons name args))] (#Cons body #Nil)) (#Some name args #None body) (#Cons name (#Cons body #Nil)) (#Some name #Nil #None body) _ #None))] (_lux_case parts (#Some name args ?type body) (let' [body' (_lux_case args #Nil body _ (` (function' (~ name) [(~@ args)] (~ body)))) body'' (_lux_case ?type (#Some type) (` (: (~ type) (~ body'))) #None body')] (return (list (` (;_lux_def (~ name) (~ body'') (~ (if export? (with-export-meta (tag$ ["lux" "Nil"])) (tag$ ["lux" "Nil"])))))))) #None (fail "Wrong syntax for def'")))) (def:' (rejoin-pair pair) (-> [AST AST] (List AST)) (let' [[left right] pair] (list left right))) (def:' (ast-to-text ast) (-> AST Text) (_lux_case ast [_ (#BoolS value)] (Bool/encode value) [_ (#NatS value)] (Nat/encode value) [_ (#IntS value)] (Int/encode value) [_ (#DegS value)] (Deg/encode value) [_ (#RealS value)] (Real/encode value) [_ (#CharS value)] ($_ Text/append "#" "\"" (Char/encode value) "\"") [_ (#TextS value)] ($_ Text/append "\"" value "\"") [_ (#SymbolS [prefix name])] (if (Text/= "" prefix) name ($_ Text/append prefix ";" name)) [_ (#TagS [prefix name])] (if (Text/= "" prefix) ($_ Text/append "#" name) ($_ Text/append "#" prefix ";" name)) [_ (#FormS xs)] ($_ Text/append "(" (|> xs (map ast-to-text) (interpose " ") reverse (fold Text/append "")) ")") [_ (#TupleS xs)] ($_ Text/append "[" (|> xs (map ast-to-text) (interpose " ") reverse (fold Text/append "")) "]") [_ (#RecordS kvs)] ($_ Text/append "{" (|> kvs (map (function' [kv] (_lux_case kv [k v] ($_ Text/append (ast-to-text k) " " (ast-to-text v))))) (interpose " ") reverse (fold Text/append "")) "}") )) (def:' (expander branches) (-> (List AST) (Lux (List AST))) (_lux_case branches (#;Cons [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] (#;Cons body branches')) (do Monad [??? (macro? macro-name)] (if ??? (do Monad [init-expansion (macro-expand-once (form$ (list& (symbol$ macro-name) (form$ macro-args) body branches')))] (expander init-expansion)) (do Monad [sub-expansion (expander branches')] (wrap (list& (form$ (list& (symbol$ macro-name) macro-args)) body sub-expansion))))) (#;Cons pattern (#;Cons body branches')) (do Monad [sub-expansion (expander branches')] (wrap (list& pattern body sub-expansion))) #;Nil (do Monad [] (wrap (list))) _ (fail ($_ Text/append "\"lux;case\" expects an even number of tokens: " (|> branches (map ast-to-text) (interpose " ") reverse (fold Text/append "")))))) (macro:' #export (case tokens) (list [["lux" "doc"] (#TextA "## The pattern-matching macro. ## Allows the usage of macros within the patterns to provide custom syntax. (case (: (List Int) (list 1 2 3)) (#Cons x (#Cons y (#Cons z #Nil))) (#Some ($_ i.* x y z)) _ #None)")]) (_lux_case tokens (#Cons value branches) (do Monad [expansion (expander branches)] (wrap (list (` (;_lux_case (~ value) (~@ expansion)))))) _ (fail "Wrong syntax for case"))) (macro:' #export (^ tokens) (list [["lux" "doc"] (#TextA "## Macro-expanding patterns. ## It's a special macro meant to be used with 'case'. (case (: (List Int) (list 1 2 3)) (^ (list x y z)) (#Some ($_ i.* x y z)) _ #None)")]) (case tokens (#Cons [_ (#FormS (#Cons pattern #Nil))] (#Cons body branches)) (do 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 [["lux" "doc"] (#TextA "## Or-patterns. ## It's a special macro meant to be used with 'case'. (type: Weekday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday #Sunday) (def: (weekend? day) (-> Weekday Bool) (case day (^or #Saturday #Sunday) true _ false))")]) (case tokens (^ (list& [_ (#FormS patterns)] body branches)) (case patterns #Nil (fail "^or cannot have 0 patterns") _ (let' [pairs (|> patterns (map (function' [pattern] (list pattern body))) (List/join))] (return (List/append pairs branches)))) _ (fail "Wrong syntax for ^or"))) (def:' (symbol? ast) (-> AST Bool) (case ast [_ (#SymbolS _)] true _ false)) (macro:' #export (let tokens) (list [["lux" "doc"] (#TextA "## Creates local bindings. ## Can (optionally) use pattern-matching macros when binding. (let [x (foo bar) y (baz quux)] (op x y))")]) (case tokens (^ (list [_ (#TupleS bindings)] body)) (if (multiple? 2 (length bindings)) (|> bindings as-pairs reverse (fold (: (-> [AST AST] AST AST) (function' [lr body'] (let' [[l r] lr] (if (symbol? l) (` (;_lux_case (~ r) (~ l) (~ body'))) (` (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 [["lux" "doc"] (#TextA "## Syntax for creating functions. ## Allows for giving the function itself a name, for the sake of recursion. (: (All [a b] (-> a b a)) (function [x y] x)) (: (All [a b] (-> a b a)) (function const [x y] x))")]) (case (: (Maybe [Ident AST (List AST) AST]) (case tokens (^ (list [_ (#TupleS (#Cons head tail))] body)) (#Some ["" ""] head tail body) (^ (list [_ (#SymbolS ["" name])] [_ (#TupleS (#Cons head tail))] body)) (#Some ["" name] head tail body) _ #None)) (#Some ident head tail body) (let [g!blank (symbol$ ["" ""]) g!name (symbol$ ident) body+ (fold (: (-> AST AST AST) (function' [arg body'] (if (symbol? arg) (` (;_lux_function (~ g!blank) (~ arg) (~ body'))) (` (;_lux_function (~ g!blank) (~ g!blank) (case (~ g!blank) (~ arg) (~ body'))))))) body (reverse tail))] (return (list (if (symbol? head) (` (;_lux_function (~ g!name) (~ head) (~ body+))) (` (;_lux_function (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) #None (fail "Wrong syntax for function"))) (def:' (process-def-meta-value ast) (-> AST (Lux AST)) (case ast [_ (#BoolS value)] (return (form$ (list (tag$ ["lux" "BoolA"]) (bool$ value)))) [_ (#NatS value)] (return (form$ (list (tag$ ["lux" "NatA"]) (nat$ value)))) [_ (#IntS value)] (return (form$ (list (tag$ ["lux" "IntA"]) (int$ value)))) [_ (#DegS value)] (return (form$ (list (tag$ ["lux" "DegA"]) (deg$ value)))) [_ (#RealS value)] (return (form$ (list (tag$ ["lux" "RealA"]) (real$ value)))) [_ (#CharS value)] (return (form$ (list (tag$ ["lux" "CharA"]) (char$ value)))) [_ (#TextS value)] (return (form$ (list (tag$ ["lux" "TextA"]) (text$ value)))) [_ (#TagS [prefix name])] (return (form$ (list (tag$ ["lux" "IdentA"]) (tuple$ (list (text$ prefix) (text$ name)))))) (^or [_ (#FormS _)] [_ (#SymbolS _)]) (return ast) [_ (#TupleS xs)] (do Monad [=xs (mapM Monad process-def-meta-value xs)] (wrap (form$ (list (tag$ ["lux" "ListA"]) (untemplate-list =xs))))) [_ (#RecordS kvs)] (do Monad [=xs (mapM Monad (: (-> [AST AST] (Lux AST)) (function [[k v]] (case k [_ (#TextS =k)] (do Monad [=v (process-def-meta-value v)] (wrap (tuple$ (list (text$ =k) =v)))) _ (fail (Text/append "Wrong syntax for DictA key: " (ast-to-text k)))))) kvs)] (wrap (form$ (list (tag$ ["lux" "DictA"]) (untemplate-list =xs))))) )) (def:' (process-def-meta ast) (-> AST (Lux AST)) (case ast [_ (#RecordS kvs)] (do Monad [=kvs (mapM Monad (: (-> [AST AST] (Lux AST)) (function [[k v]] (case k [_ (#TagS [pk nk])] (do Monad [=v (process-def-meta-value v)] (wrap (tuple$ (list (tuple$ (list (text$ pk) (text$ nk))) =v)))) _ (fail (Text/append "Wrong syntax for Anns: " (ast-to-text ast)))))) kvs)] (wrap (untemplate-list =kvs))) _ (fail (Text/append "Wrong syntax for Anns: " (ast-to-text ast))))) (def:' (with-func-args args meta) (-> (List AST) AST AST) (case args #;Nil meta _ (` (#;Cons [["lux" "func-args"] (#;ListA (list (~@ (map (function [arg] (` (#;TextA (~ (text$ (ast-to-text arg)))))) args))))] (~ meta))))) (def:' (with-type-args args) (-> (List AST) AST) (` {#;type-args (#;ListA (list (~@ (map (function [arg] (` (#;TextA (~ (text$ (ast-to-text arg)))))) args))))})) (def:' Export-Level Type ($' Either Unit ## Exported Unit ## Hidden )) (def:' (export-level^ tokens) (-> (List AST) [(Maybe Export-Level) (List AST)]) (case tokens (#Cons [_ (#TagS [_ "export"])] tokens') [(#;Some (#;Left [])) tokens'] (#Cons [_ (#TagS [_ "hidden"])] tokens') [(#;Some (#;Right [])) tokens'] _ [#;None tokens])) (def:' (export-level ?el) (-> (Maybe Export-Level) (List AST)) (case ?el #;None (list) (#;Some (#;Left [])) (list (' #export)) (#;Some (#;Right [])) (list (' #hidden)))) (macro:' #export (def: tokens) (list [["lux" "doc"] (#TextA "## Defines global constants/functions. (def: (rejoin-pair pair) (-> [AST AST] (List AST)) (let [[left right] pair] (list left right))) (def: branching-exponent Int 5)")]) (let [[export? tokens'] (export-level^ tokens) parts (: (Maybe [AST (List AST) (Maybe AST) AST AST]) (case tokens' (^ (list [_ (#FormS (#Cons name args))] meta type body)) (#Some [name args (#Some type) body meta]) (^ (list name meta type body)) (#Some [name #Nil (#Some type) body meta]) (^ (list [_ (#FormS (#Cons name args))] [_ (#RecordS meta-kvs)] body)) (#Some [name args #None body (record$ meta-kvs)]) (^ (list name [_ (#RecordS meta-kvs)] body)) (#Some [name #Nil #None body (record$ meta-kvs)]) (^ (list [_ (#FormS (#Cons name args))] type body)) (#Some [name args (#Some type) body (' {})]) (^ (list name type body)) (#Some [name #Nil (#Some type) body (' {})]) (^ (list [_ (#FormS (#Cons name args))] body)) (#Some [name args #None body (' {})]) (^ (list name body)) (#Some [name #Nil #None body (' {})]) _ #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)] (do Monad [=meta (process-def-meta meta)] (return (list (` (;_lux_def (~ name) (~ body) (~ (with-func-args args (case export? #;None =meta (#;Some (#;Left [])) (with-export-meta =meta) (#;Some (#;Right [])) (|> =meta with-export-meta with-hidden-meta) ))))))))) #None (fail "Wrong syntax for def")))) (def: (meta-ast-add addition meta) (-> [AST AST] AST AST) (case [addition meta] [[name value] [cursor (#;RecordS pairs)]] [cursor (#;RecordS (#;Cons [name value] pairs))] _ meta)) (def: (meta-ast-merge addition base) (-> AST AST AST) (case addition [cursor (#;RecordS pairs)] (fold meta-ast-add base pairs) _ base)) (macro:' #export (macro: tokens) (list [["lux" "doc"] (#TextA "Macro-definition macro. (macro: #export (ident-for tokens) (case tokens (^template [] (^ (list [_ ( [prefix name])])) (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))) ([#;SymbolS] [#;TagS]) _ (fail \"Wrong syntax for ident-for\")))")]) (let [[exported? tokens] (export-level^ tokens) name+args+meta+body?? (: (Maybe [Ident (List AST) AST AST]) (case tokens (^ (list [_ (#;FormS (list& [_ (#SymbolS name)] args))] body)) (#Some [name args (` {}) body]) (^ (list [_ (#;SymbolS name)] body)) (#Some [name #Nil (` {}) body]) (^ (list [_ (#;FormS (list& [_ (#SymbolS name)] args))] [meta-rec-cursor (#;RecordS meta-rec-parts)] body)) (#Some [name args [meta-rec-cursor (#;RecordS meta-rec-parts)] body]) (^ (list [_ (#;SymbolS name)] [meta-rec-cursor (#;RecordS meta-rec-parts)] body)) (#Some [name #Nil [meta-rec-cursor (#;RecordS meta-rec-parts)] body]) _ #None))] (case name+args+meta+body?? (#Some [name args meta body]) (let [name (symbol$ name) def-sig (case args #;Nil name _ (` ((~ name) (~@ args))))] (return (list (` (;;def: (~@ (export-level exported?)) (~ def-sig) (~ (meta-ast-merge (` {#;macro? true}) meta)) ;;Macro (~ body)))))) #None (fail "Wrong syntax for macro:")))) (macro: #export (sig: tokens) {#;doc "## Definition of signatures ala ML. (sig: #export (Ord a) (: (Eq a) eq) (: (-> a a Bool) <) (: (-> a a Bool) <=) (: (-> a a Bool) >) (: (-> a a Bool) >=))"} (let [[exported? tokens'] (export-level^ tokens) ?parts (: (Maybe [Ident (List AST) AST (List AST)]) (case tokens' (^ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs)) (#Some name args [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs) (^ (list& [_ (#SymbolS name)] [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs)) (#Some name #Nil [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs) (^ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] sigs)) (#Some name args (` {}) sigs) (^ (list& [_ (#SymbolS name)] sigs)) (#Some name #Nil (` {}) sigs) _ #None))] (case ?parts (#Some name args meta sigs) (do Monad [name+ (normalize name) sigs' (mapM Monad macro-expand sigs) members (: (Lux (List [Text AST])) (mapM Monad (: (-> AST (Lux [Text AST])) (function [token] (case token (^ [_ (#FormS (list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))]) (wrap [name type]) _ (fail "Signatures require typed members!")))) (List/join sigs'))) #let [[_module _name] name+ def-name (symbol$ name) sig-type (record$ (map (: (-> [Text AST] [AST AST]) (function [[m-name m-type]] [(tag$ ["" m-name]) m-type])) members)) sig-meta (meta-ast-merge (` {#;sig? true}) meta) usage (case args #;Nil def-name _ (` ((~ def-name) (~@ args))))]] (return (list (` (;;type: (~@ (export-level exported?)) (~ usage) (~ sig-meta) (~ sig-type)))))) #None (fail "Wrong syntax for sig:")))) (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)))) (do-template [ ] [(def: ( part text) (-> Text Text (Maybe Nat)) (_lux_proc ["text" ] [text part ]))] [index-of "index" +0] [last-index-of "last-index" (_lux_proc ["text" "size"] [text])] ) (def: (clip1 from text) (-> Nat Text (Maybe Text)) (_lux_proc ["text" "clip"] [text from (_lux_proc ["text" "size"] [text])])) (def: (clip2 from to text) (-> Nat Nat Text (Maybe Text)) (_lux_proc ["text" "clip"] [text from to])) (def: #export (error! message) {#;doc "## Causes an error, with the given error message. (error! \"OH NO!\")"} (-> Text Bottom) (_lux_proc ["io" "error"] [message])) (macro: #export (default tokens state) {#;doc "## Allows you to provide a default value that will be used ## if a (Maybe x) value turns out to be #;None. (default 20 (#;Some 10)) => 10 (default 20 #;None) => 20"} (case tokens (^ (list else maybe)) (let [g!temp (: AST [_cursor (#;SymbolS ["" ""])]) code (` (case (~ maybe) (#;Some (~ g!temp)) (~ g!temp) #;None (~ else)))] (#;Right [state (list code)])) _ (#;Left "Wrong syntax for ?"))) (def: (split-text splitter input) (-> Text Text (List Text)) (case (index-of splitter input) #;None (#Cons input #Nil) (#;Some idx) (#Cons (default (error! "UNDEFINED") (clip2 +0 idx input)) (split-text splitter (default (error! "UNDEFINED") (clip1 (n.+ +1 idx) input)))))) (def: (split-module-contexts module) (-> Text (List Text)) (#Cons module (case (last-index-of "/" module) #;None #Nil (#;Some idx) (split-module-contexts (default (error! "UNDEFINED") (clip2 +0 idx module)))))) (def: (split-module module) (-> Text (List Text)) (case (index-of "/" module) #;None (list module) (#;Some idx) (list& (default (error! "UNDEFINED") (clip2 +0 idx module)) (split-module (default (error! "UNDEFINED") (clip1 (n.+ +1 idx) module)))))) (def: (nth idx xs) (All [a] (-> Int (List a) (Maybe a))) (case xs #Nil #None (#Cons x xs') (if (i.= idx 0) (#Some x) (nth (i.- 1 idx) xs') ))) (def: (beta-reduce env type) (-> (List Type) Type Type) (case type (#SumT left right) (#SumT (beta-reduce env left) (beta-reduce env right)) (#ProdT left right) (#ProdT (beta-reduce env left) (beta-reduce env right)) (#AppT ?type-fn ?type-arg) (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) (#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) (#FunctionT ?input ?output) (#FunctionT (beta-reduce env ?input) (beta-reduce env ?output)) (#BoundT idx) (case (nth (_lux_proc ["nat" "to-int"] [idx]) env) (#Some bound) bound _ type) (#NamedT 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)) (#AppT F A) (do Monad [type-fn* (apply-type F A)] (apply-type type-fn* param)) (#NamedT name type) (apply-type type param) _ #None)) (do-template [ ] [(def: ( type) (-> Type (List Type)) (case type ( left right) (list& left ( right)) _ (list type)))] [flatten-variant #;SumT] [flatten-tuple #;ProdT] [flatten-lambda #;FunctionT] [flatten-app #;AppT] ) (def: (resolve-struct-type type) (-> Type (Maybe (List Type))) (case type (#ProdT _) (#Some (flatten-tuple type)) (#AppT fun arg) (do Monad [output (apply-type fun arg)] (resolve-struct-type output)) (#UnivQ _ body) (resolve-struct-type body) (#ExQ _ body) (resolve-struct-type body) (#NamedT name type) (resolve-struct-type type) (#SumT _) #None _ (#Some (list type)))) (def: (find-module name) (-> Text (Lux Module)) (function [state] (let [{#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars} state] (case (get name modules) (#Some module) (#Right state module) _ (#Left ($_ Text/append "Unknown module: " name)))))) (def: get-current-module (Lux Module) (do Monad [module-name current-module-name] (find-module module-name))) (def: (resolve-tag [module name]) (-> Ident (Lux [Nat (List Ident) Bool Type])) (do Monad [=module (find-module module) #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags-table #types types #module-anns _ #module-state _} =module]] (case (get name tags-table) (#Some output) (return output) _ (fail (Text/append "Unknown tag: " (Ident/encode [module name])))))) (def: (resolve-type-tags type) (-> Type (Lux (Maybe [(List Ident) (List Type)]))) (case type (#AppT fun arg) (resolve-type-tags fun) (#UnivQ env body) (resolve-type-tags body) (#ExQ env body) (resolve-type-tags body) (#NamedT [module name] _) (do Monad [=module (find-module module) #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _ #module-state _} =module]] (case (get name types) (#Some [tags exported? (#NamedT _ _type)]) (case (resolve-struct-type _type) (#Some members) (return (#Some [tags members])) _ (return #None)) _ (return #None))) _ (return #None))) (def: get-expected-type (Lux Type) (function [state] (let [{#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars} state] (case expected (#Some type) (#Right state type) #None (#Left "Not expecting any type."))))) (macro: #export (struct tokens) {#;doc "Not meant to be used directly. Prefer \"struct:\"."} (do Monad [tokens' (mapM Monad macro-expand tokens) struct-type get-expected-type tags+type (resolve-type-tags struct-type) tags (: (Lux (List Ident)) (case tags+type (#Some [tags _]) (return tags) _ (fail "No tags available for type."))) #let [tag-mappings (: (List [Text AST]) (map (function [tag] [(second tag) (tag$ tag)]) tags))] members (mapM Monad (: (-> AST (Lux [AST AST])) (function [token] (case token (^ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value meta))]) (case (get tag-name tag-mappings) (#Some tag) (wrap [tag value]) _ (fail (Text/append "Unknown structure member: " tag-name))) _ (fail "Invalid structure member.")))) (List/join tokens'))] (wrap (list (record$ members))))) (def: (Text/join parts) (-> (List Text) Text) (|> parts reverse (fold Text/append ""))) (macro: #export (struct: tokens) {#;doc "## Definition of structures ala ML. (struct: #export Ord (Ord Int) (def: eq Eq) (def: (< test subject) (lux;< test subject)) (def: (<= test subject) (or (lux;< test subject) (lux;= test subject))) (def: (lux;> test subject) (lux;> test subject)) (def: (lux;>= test subject) (or (lux;> test subject) (lux;= test subject))))"} (let [[exported? tokens'] (export-level^ tokens) ?parts (: (Maybe [AST (List AST) AST AST (List AST)]) (case tokens' (^ (list& [_ (#FormS (list& name args))] [meta-rec-cursor (#;RecordS meta-rec-parts)] type defs)) (#Some name args type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs) (^ (list& name [meta-rec-cursor (#;RecordS meta-rec-parts)] type defs)) (#Some name #Nil type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs) (^ (list& [_ (#FormS (list& name args))] type defs)) (#Some name args type (` {}) defs) (^ (list& name type defs)) (#Some name #Nil type (` {}) defs) _ #None))] (case ?parts (#Some [name args type meta defs]) (case (case name [_ (#;SymbolS ["" "_"])] (case type (^ [_ (#;FormS (list& [_ (#;SymbolS [_ sig-name])] sig-args))]) (case (: (Maybe (List Text)) (mapM Monad (function [sa] (case sa [_ (#;SymbolS [_ arg-name])] (#;Some arg-name) _ #;None)) sig-args)) (^ (#;Some params)) (#;Some (symbol$ ["" ($_ Text/append sig-name "<" (|> params (interpose ",") Text/join) ">")])) _ #;None) _ #;None) _ (#;Some name) ) (#;Some name) (let [usage (case args #Nil name _ (` ((~ name) (~@ args))))] (return (list (` (;;def: (~@ (export-level exported?)) (~ usage) (~ (meta-ast-merge (` {#;struct? true}) meta)) (~ type) (struct (~@ defs))))))) #;None (fail "Struct must have a name other than \"_\"!")) #None (fail "Wrong syntax for struct:")))) (def: #export (id x) {#;doc "Identity function. Does nothing to it's argument and just returns it."} (All [a] (-> a a)) x) (do-template [
] [(macro: #export ( tokens) {#;doc } (case (reverse tokens) (^ (list& last init)) (return (list (fold (: (-> AST AST AST) (function [pre post] (` ))) last init))) _ (fail )))] [and (if (~ pre) (~ post) false) "'and' requires >=1 clauses." "Short-circuiting \"and\".\n(and true false true) ## => false"] [or (if (~ pre) true (~ post)) "'or' requires >=1 clauses." "Short-circuiting \"or\".\n(or true false true) ## => true"]) (macro: #export (type: tokens) {#;doc "## The type-definition macro. (type: (List a) #Nil (#Cons a (List a)))"} (let [[exported? tokens'] (export-level^ tokens) [rec? tokens'] (case tokens' (#Cons [_ (#TagS [_ "rec"])] tokens') [true tokens'] _ [false tokens']) parts (: (Maybe [Text (List AST) AST (List AST)]) (case tokens' (^ (list [_ (#SymbolS "" name)] [meta-cursor (#;RecordS meta-parts)] [type-cursor (#;RecordS type-parts)])) (#Some [name #Nil [meta-cursor (#;RecordS meta-parts)] (list [type-cursor (#;RecordS type-parts)])]) (^ (list& [_ (#SymbolS "" name)] [meta-cursor (#;RecordS meta-parts)] type-ast1 type-asts)) (#Some [name #Nil [meta-cursor (#;RecordS meta-parts)] (#;Cons type-ast1 type-asts)]) (^ (list& [_ (#SymbolS "" name)] type-asts)) (#Some [name #Nil (` {}) type-asts]) (^ (list [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] [meta-cursor (#;RecordS meta-parts)] [type-cursor (#;RecordS type-parts)])) (#Some [name args [meta-cursor (#;RecordS meta-parts)] (list [type-cursor (#;RecordS type-parts)])]) (^ (list& [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] [meta-cursor (#;RecordS meta-parts)] type-ast1 type-asts)) (#Some [name args [meta-cursor (#;RecordS meta-parts)] (#;Cons type-ast1 type-asts)]) (^ (list& [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] type-asts)) (#Some [name args (` {}) type-asts]) _ #None))] (case parts (#Some name args meta type-asts) (do Monad [type+tags?? (unfold-type-def type-asts) module-name current-module-name] (let [type-name (symbol$ ["" name]) [type tags??] type+tags?? type-meta (: AST (case tags?? (#Some tags) (` {#;tags [(~@ (map (: (-> Text AST) (function' [tag] (form$ (list (tag$ ["lux" "TextA"]) (text$ tag))))) tags))] #;type? true}) _ (` {#;type? true}))) type' (: (Maybe AST) (if rec? (if (empty? args) (let [g!param (symbol$ ["" ""]) prime-name (symbol$ ["" (Text/append name "'")]) type+ (replace-syntax (list [name (` ((~ prime-name) (~ g!param)))]) type)] (#Some (` ((All (~ prime-name) [(~ g!param)] (~ type+)) Void)))) #None) (case args #Nil (#Some type) _ (#Some (` (All (~ type-name) [(~@ args)] (~ type)))))))] (case type' (#Some type'') (return (list (` (;;def: (~@ (export-level exported?)) (~ type-name) (~ ($_ meta-ast-merge (with-type-args args) (if rec? (' {#;type-rec? true}) (' {})) type-meta meta)) Type (#;NamedT [(~ (text$ module-name)) (~ (text$ name))] (type (~ type''))))))) #None (fail "Wrong syntax for type:")))) #None (fail "Wrong syntax for type:")) )) (type: Referrals #All (#Only (List Text)) (#Exclude (List Text)) #Nothing) (type: Openings [Text (List Ident)]) (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 AST) (Lux (List Text))) (mapM Monad (: (-> AST (Lux Text)) (function [def] (case def [_ (#SymbolS ["" name])] (return name) _ (fail "only/exclude requires symbols.")))) defs)) (def: (parse-alias tokens) (-> (List AST) (Lux [(Maybe Text) (List AST)])) (case tokens (^ (list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) (return [(#Some alias) tokens']) _ (return [#None tokens]))) (def: (parse-referrals tokens) (-> (List AST) (Lux [Referrals (List AST)])) (case tokens (^ (list& [_ (#TagS ["" "refer"])] referral tokens')) (case referral [_ (#TagS "" "all")] (return [#All tokens']) (^ [_ (#FormS (list& [_ (#TagS ["" "only"])] defs))]) (do Monad [defs' (extract-defs defs)] (return [(#Only defs') tokens'])) (^ [_ (#FormS (list& [_ (#TagS ["" "exclude"])] defs))]) (do Monad [defs' (extract-defs defs)] (return [(#Exclude defs') tokens'])) _ (fail "Incorrect syntax for referral.")) _ (return [#Nothing tokens]))) (def: (split-with' p ys xs) (All [a] (-> (-> a Bool) (List a) (List a) [(List a) (List a)])) (case xs #Nil [ys xs] (#Cons x xs') (if (p x) (split-with' p (list& x ys) xs') [ys xs]))) (def: (split-with p xs) (All [a] (-> (-> a Bool) (List a) [(List a) (List a)])) (let [[ys' xs'] (split-with' p #Nil xs)] [(reverse ys') xs'])) (def: (parse-short-referrals tokens) (-> (List AST) (Lux [Referrals (List AST)])) (case tokens (^ (list& [_ (#TagS "" "+")] tokens')) (let [[defs tokens'] (split-with symbol? tokens')] (do Monad [defs' (extract-defs defs)] (return [(#Only defs') tokens']))) (^ (list& [_ (#TagS "" "-")] tokens')) (let [[defs tokens'] (split-with symbol? tokens')] (do Monad [defs' (extract-defs defs)] (return [(#Exclude defs') tokens']))) (^ (list& [_ (#TagS "" "*")] tokens')) (return [#All tokens']) _ (return [#Nothing tokens]))) (def: (extract-symbol syntax) (-> AST (Lux Ident)) (case syntax [_ (#SymbolS ident)] (return ident) _ (fail "Not a symbol."))) (def: (parse-openings tokens) (-> (List AST) (Lux [(List Openings) (List AST)])) (case tokens (^ (list& [_ (#TagS "" "open")] [_ (#FormS parts)] tokens')) (if (|> parts (map (: (-> AST Bool) (function [part] (case part (^or [_ (#TextS _)] [_ (#SymbolS _)]) true _ false)))) (fold (function [r l] (and l r)) true)) (let [openings (fold (: (-> AST (List Openings) (List Openings)) (function [part openings] (case part [_ (#TextS prefix)] (list& [prefix (list)] openings) [_ (#SymbolS struct-name)] (case openings #Nil (list ["" (list struct-name)]) (#Cons [prefix structs] openings') (#Cons [prefix (#Cons struct-name structs)] openings')) _ openings))) (: (List Openings) (list)) parts)] (return [openings tokens'])) (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol).")) _ (return [(list) tokens]))) (def: (parse-short-openings parts) (-> (List AST) (Lux [(List Openings) (List AST)])) (if (|> parts (map (: (-> AST Bool) (function [part] (case part (^or [_ (#TextS _)] [_ (#SymbolS _)]) true _ false)))) (fold (function [r l] (and l r)) true)) (let [openings (fold (: (-> AST (List Openings) (List Openings)) (function [part openings] (case part [_ (#TextS prefix)] (list& [prefix (list)] openings) [_ (#SymbolS struct-name)] (case openings #Nil (list ["" (list struct-name)]) (#Cons [prefix structs] openings') (#Cons [prefix (#Cons struct-name structs)] openings')) _ openings))) (: (List Openings) (list)) parts)] (return [openings (list)])) (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol)."))) (def: (decorate-sub-importations super-name) (-> Text (List Importation) (List Importation)) (map (: (-> Importation Importation) (function [importation] (let [{#import-name _name #import-alias _alias #import-refer {#refer-defs _referrals #refer-open _openings}} importation] {#import-name ($_ Text/append super-name "/" _name) #import-alias _alias #import-refer {#refer-defs _referrals #refer-open _openings}}))))) (def: (replace-all pattern value template) (-> Text Text Text Text) (_lux_proc ["text" "replace-all"] [template pattern value])) (def: (clean-module module) (-> Text (Lux Text)) (do Monad [current-module current-module-name] (case (split-module module) (^ (list& "." parts)) (return (|> (list& current-module parts) (interpose "/") reverse (fold Text/append ""))) parts (let [[ups parts'] (split-with (Text/= "..") parts) num-ups (length ups)] (if (i.= num-ups 0) (return module) (case (nth num-ups (split-module-contexts current-module)) #None (fail (Text/append "Cannot clean module: " module)) (#Some top-module) (return (|> (list& top-module parts') (interpose "/") reverse (fold Text/append "")))) ))) )) (def: (parse-imports imports) (-> (List AST) (Lux (List Importation))) (do Monad [imports' (mapM Monad (: (-> AST (Lux (List Importation))) (function [token] (case token [_ (#SymbolS "" m-name)] (do Monad [m-name (clean-module m-name)] (wrap (list [m-name #None {#refer-defs #All #refer-open (list)}]))) (^ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))]) (do Monad [m-name (clean-module m-name) alias+extra (parse-alias extra) #let [[alias extra] alias+extra] referral+extra (parse-referrals extra) #let [[referral extra] referral+extra] openings+extra (parse-openings extra) #let [[openings extra] openings+extra] sub-imports (parse-imports extra) #let [sub-imports (decorate-sub-importations m-name sub-imports)]] (wrap (case [referral alias openings] [#Nothing #None #Nil] sub-imports _ (list& {#import-name m-name #import-alias alias #import-refer {#refer-defs referral #refer-open openings}} sub-imports)))) (^ [_ (#TupleS (list& [_ (#TextS alias)] [_ (#SymbolS "" m-name)] extra))]) (do Monad [m-name (clean-module m-name) referral+extra (parse-short-referrals extra) #let [[referral extra] referral+extra] openings+extra (parse-short-openings extra) #let [[openings extra] openings+extra]] (wrap (list {#import-name m-name #import-alias (#;Some (replace-all ";" m-name alias)) #import-refer {#refer-defs referral #refer-open openings}}))) (^ [_ (#TupleS (list& [_ (#SymbolS "" m-name)] extra))]) (do Monad [m-name (clean-module m-name) referral+extra (parse-short-referrals extra) #let [[referral extra] referral+extra] openings+extra (parse-short-openings extra) #let [[openings extra] openings+extra]] (wrap (list {#import-name m-name #import-alias (#;Some m-name) #import-refer {#refer-defs referral #refer-open openings}}))) _ (do Monad [current-module current-module-name] (fail (Text/append "Wrong syntax for import @ " current-module)))))) imports)] (wrap (List/join imports')))) (def: (exported-defs module state) (-> Text (Lux (List Text))) (let [modules (case state {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars} modules)] (case (get module modules) (#Some =module) (let [to-alias (map (: (-> [Text Def] (List Text)) (function [[name [def-type def-meta def-value]]] (case [(get-meta ["lux" "export?"] def-meta) (get-meta ["lux" "hidden?"] def-meta)] [(#Some (#BoolA true)) #;None] (list name) _ (list)))) (let [{#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _ #module-state _} =module] defs))] (#Right state (List/join to-alias))) #None (#Left ($_ Text/append "Unknown module: " module))) )) (def: (filter p xs) (All [a] (-> (-> a Bool) (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 Bool) (let [output (fold (function [case prev] (or prev (Text/= case name))) false 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 Compiler (Maybe Type)) (case state {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars} (find (: (-> Scope (Maybe Type)) (function [env] (case env {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} (try-both (find (: (-> [Text Analysis] (Maybe Type)) (function [[bname [[type _] _]]] (if (Text/= name bname) (#Some type) #None)))) locals closure)))) scopes))) (def: (find-def-type name state) (-> Ident Compiler (Maybe Type)) (let [[v-prefix v-name] name {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars} state] (case (get v-prefix modules) #None #None (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _ #module-state _}) (case (get v-name defs) #None #None (#Some [def-type def-meta def-value]) (#Some def-type))))) (def: (find-def-value name state) (-> Ident (Lux [Type Void])) (let [[v-prefix v-name] name {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars} state] (case (get v-prefix modules) #None (#Left (Text/append "Unknown definition: " (Ident/encode name))) (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _ #module-state _}) (case (get v-name defs) #None (#Left (Text/append "Unknown definition: " (Ident/encode name))) (#Some [def-type def-meta def-value]) (#Right [state [def-type def-value]]))))) (def: (find-type ident) (-> Ident (Lux Type)) (do Monad [#let [[module name] ident] current-module current-module-name] (function [state] (if (Text/= "" module) (case (find-in-env name state) (#Some struct-type) (#Right state struct-type) _ (case (find-def-type [current-module name] state) (#Some struct-type) (#Right state struct-type) _ (#Left ($_ Text/append "Unknown var: " (Ident/encode ident))))) (case (find-def-type ident state) (#Some struct-type) (#Right state struct-type) _ (#Left ($_ Text/append "Unknown var: " (Ident/encode ident))))) ))) (def: (zip2 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] (zip2 xs' ys')) _ (list)) _ (list))) (def: (Type/show type) (-> Type Text) (case type (#HostT name params) (case params #;Nil name _ ($_ Text/append "(" name " " (|> params (map Type/show) (interpose " ") reverse (fold Text/append "")) ")")) #VoidT "Void" #UnitT "Unit" (#SumT _) ($_ Text/append "(| " (|> (flatten-variant type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")") (#ProdT _) ($_ Text/append "[" (|> (flatten-tuple type) (map Type/show) (interpose " ") reverse (fold Text/append "")) "]") (#FunctionT _) ($_ Text/append "(-> " (|> (flatten-lambda type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")") (#BoundT id) (Nat/encode id) (#VarT id) ($_ Text/append "⌈v:" (Nat/encode id) "⌋") (#ExT id) ($_ Text/append "⟨e:" (Nat/encode id) "⟩") (#UnivQ env body) ($_ Text/append "(All " (Type/show body) ")") (#ExQ env body) ($_ Text/append "(Ex " (Type/show body) ")") (#AppT _) ($_ Text/append "(" (|> (flatten-app type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")") (#NamedT [prefix name] _) ($_ Text/append prefix ";" name) )) (def: (foldM Monad f init inputs) (All [m o i] (-> (Monad m) (-> i o (m o)) o (List i) (m o))) (case inputs #;Nil (do Monad [] (wrap init)) (#;Cons input inputs') (do Monad [output (f input init)] (foldM Monad f output inputs')))) (macro: #hidden (^open' tokens) (case tokens (^ (list [_ (#SymbolS name)] [_ (#TextS prefix)] body)) (do Monad [init-type (find-type name) struct-evidence (resolve-type-tags init-type)] (case struct-evidence #;None (fail (Text/append "Can only \"open\" structs: " (Type/show init-type))) (#;Some tags&members) (do Monad [full-body ((: (-> Ident [(List Ident) (List Type)] AST (Lux AST)) (function recur [source [tags members] target] (let [pattern (record$ (map (function [[t-module t-name]] [(tag$ [t-module t-name]) (symbol$ ["" (Text/append prefix t-name)])]) tags))] (do Monad [enhanced-target (foldM Monad (function [[[_ m-name] m-type] enhanced-target] (do Monad [m-structure (resolve-type-tags m-type)] (case m-structure (#;Some m-tags&members) (recur ["" (Text/append prefix m-name)] m-tags&members enhanced-target) #;None (wrap enhanced-target)))) target (zip2 tags members))] (wrap (` (;_lux_case (~ (symbol$ source)) (~ pattern) (~ enhanced-target)))))))) name tags&members body)] (wrap (list full-body))))) _ (fail "Wrong syntax for ^open"))) (macro: #export (^open tokens) {#;doc "## Same as the \"open\" macro, but meant to be used as a pattern-matching macro for generating local bindings. ## Can optionally take a \"prefix\" text for the generated local bindings. (def: #export (range (^open) from to) (All [a] (-> (Enum a) a a (List a))) (range' <= succ from to))"} (case tokens (^ (list& [_ (#FormS (list [_ (#TextS prefix)]))] body branches)) (do Monad [g!temp (gensym "temp")] (return (list& g!temp (` (^open' (~ g!temp) (~ (text$ prefix)) (~ body))) branches))) (^ (list& [_ (#FormS (list))] body branches)) (return (list& (` (;;^open "")) body branches)) _ (fail "Wrong syntax for ^open"))) (macro: #export (cond tokens) {#;doc "## Branching structures with multiple test conditions. (cond (n.even? num) \"even\" (n.odd? num) \"odd\" ## else-branch \"???\")"} (if (i.= 0 (i.% 2 (length tokens))) (fail "cond requires an even number of arguments.") (case (reverse tokens) (^ (list& else branches')) (return (list (fold (: (-> [AST AST] AST AST) (function [branch else] (let [[right left] branch] (` (if (~ left) (~ right) (~ else)))))) else (as-pairs branches')))) _ (fail "Wrong syntax for cond")))) (def: (enumerate' idx xs) (All [a] (-> Nat (List a) (List [Nat a]))) (case xs (#Cons x xs') (#Cons [idx x] (enumerate' (n.+ +1 idx) xs')) #Nil #Nil)) (def: (enumerate xs) (All [a] (-> (List a) (List [Nat a]))) (enumerate' +0 xs)) (macro: #export (get@ tokens) {#;doc "## Accesses the value of a record at a given tag. (get@ #field my-record) ## Can also work with multiple levels of nesting: (get@ [#foo #bar #baz] my-record) ## And, if only the slot/path is given, generates an ## accessor function: (let [getter (get@ [#foo #bar #baz])] (getter my-record))"} (case tokens (^ (list [_ (#TagS slot')] record)) (do 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$ (map (: (-> [Ident [Nat Type]] [AST AST]) (function [[[r-prefix r-name] [r-idx r-type]]] [(tag$ [r-prefix r-name]) (if (n.= idx r-idx) g!output g!_)])) (zip2 tags (enumerate members))))] (return (list (` (;_lux_case (~ record) (~ pattern) (~ g!output)))))) _ (fail "get@ can only use records."))) (^ (list [_ (#TupleS slots)] record)) (return (list (fold (: (-> AST AST AST) (function [slot inner] (` (;;get@ (~ slot) (~ inner))))) record slots))) (^ (list selector)) (do Monad [g!record (gensym "record")] (wrap (list (` (function [(~ g!record)] (;;get@ (~ selector) (~ g!record))))))) _ (fail "Wrong syntax for get@"))) (def: (open-field prefix [module name] source type) (-> Text Ident AST Type (Lux (List AST))) (do Monad [output (resolve-type-tags type) #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]] (case output (#Some [tags members]) (do Monad [decls' (mapM Monad (: (-> [Ident Type] (Lux (List AST))) (function [[sname stype]] (open-field prefix sname source+ stype))) (zip2 tags members))] (return (List/join decls'))) _ (return (list (` (;_lux_def (~ (symbol$ ["" (Text/append prefix name)])) (~ source+) #Nil))))))) (macro: #export (open tokens) {#;doc "## Opens a structure and generates a definition for each of its members (including nested members). ## For example: (open Number \"i:\") ## Will generate: (def: i:+ (:: Number +)) (def: i:- (:: Number -)) (def: i:* (:: Number *)) ..."} (case tokens (^ (list& [_ (#SymbolS struct-name)] tokens')) (do Monad [@module current-module-name #let [prefix (case tokens' (^ (list [_ (#TextS prefix)])) prefix _ "")] struct-type (find-type struct-name) output (resolve-type-tags struct-type) #let [source (symbol$ struct-name)]] (case output (#Some [tags members]) (do Monad [decls' (mapM Monad (: (-> [Ident Type] (Lux (List AST))) (function [[sname stype]] (open-field prefix sname source stype))) (zip2 tags members))] (return (List/join decls'))) _ (fail (Text/append "Can only \"open\" structs: " (Type/show struct-type))))) _ (fail "Wrong syntax for open"))) (macro: #export (|>. tokens) {#;doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it. (|> (map Int/encode) (interpose \" \") (fold Text/append \"\")) ## => (function [] (fold Text/append \"\" (interpose \" \" (map Int/encode ))))"} (do Monad [g!arg (gensym "arg")] (return (list (` (function [(~ g!arg)] (|> (~ g!arg) (~@ tokens)))))))) (def: (imported-by? import-name module-name) (-> Text Text (Lux Bool)) (do Monad [module (find-module module-name) #let [{#module-hash _ #module-aliases _ #defs _ #imports imports #tags _ #types _ #module-anns _ #module-state _} module]] (wrap (is-member? imports import-name)))) (def: (read-refer module-name options) (-> Text (List AST) (Lux Refer)) (do 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 #let [test-referrals (: (-> Text (List Text) (List Text) (Lux (List Unit))) (function [module-name all-defs referred-defs] (mapM Monad (: (-> Text (Lux Unit)) (function [_def] (if (is-member? all-defs _def) (return []) (fail ($_ Text/append _def " is not defined in module " module-name " @ " current-module))))) referred-defs)))]] (case options #;Nil (wrap {#refer-defs referral #refer-open openings}) _ (fail ($_ Text/append "Wrong syntax for refer @ " current-module "\n" (|> options (map ast-to-text) (interpose " ") (fold Text/append ""))))))) (def: (write-refer module-name [r-defs r-opens]) (-> Text Refer (Lux (List AST))) (do Monad [current-module current-module-name #let [test-referrals (: (-> Text (List Text) (List Text) (Lux (List Unit))) (function [module-name all-defs referred-defs] (mapM Monad (: (-> Text (Lux Unit)) (function [_def] (if (is-member? all-defs _def) (return []) (fail ($_ Text/append _def " is not defined in module " module-name " @ " current-module))))) referred-defs)))] defs' (case r-defs #All (exported-defs module-name) (#Only +defs) (do Monad [*defs (exported-defs module-name) _ (test-referrals module-name *defs +defs)] (wrap +defs)) (#Exclude -defs) (do Monad [*defs (exported-defs module-name) _ (test-referrals module-name *defs -defs)] (wrap (filter (|>. (is-member? -defs) not) *defs))) #Nothing (wrap (list))) #let [defs (map (: (-> Text AST) (function [def] (` (;_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [module-name def])) (#Cons [["lux" "alias"] (#IdentA [(~ (text$ module-name)) (~ (text$ def))])] #Nil))))) defs') openings (join-map (: (-> Openings (List AST)) (function [[prefix structs]] (map (function [[_ name]] (` (open (~ (symbol$ [module-name name])) (~ (text$ prefix))))) structs))) r-opens)]] (wrap (List/append defs openings)) )) (macro: #hidden (refer tokens) (case tokens (^ (list& [_ (#TextS module-name)] options)) (do Monad [=refer (read-refer module-name options)] (write-refer module-name =refer)) _ (fail "Wrong syntax for refer"))) (def: (refer-to-ast module-name [r-defs r-opens]) (-> Text Refer AST) (let [=defs (: (List AST) (case r-defs #All (list (' #refer) (' #all)) (#Only defs) (list (' #refer) (`' (#only (~@ (map (|>. [""] symbol$) defs))))) (#Exclude defs) (list (' #refer) (`' (#exclude (~@ (map (|>. [""] symbol$) defs))))) #Nothing (list))) =opens (join-map (function [[prefix structs]] (list& (text$ prefix) (map symbol$ structs))) r-opens)] (` (;;refer (~ (text$ module-name)) (~@ =defs) (~' #open) ((~@ =opens)))))) (macro: #export (module: tokens) {#;doc "Module-definition macro. Can take optional annotations and allows the specification of modules to import. ## Examples (;module: {#;doc \"Some documentation...\"} lux (lux (control (monad #as M #refer #all)) (data (text #open (\"Text/\" Monoid)) (coll (list #open (\"List/\" Monad))) maybe (ident #open (\"Ident/\" Codec))) meta (macro ast)) (.. (type #open (\"\" Eq)))) (;module: {#;doc \"Some documentation...\"} lux (lux (control [\"M\" monad #*]) (data [text \"Text/\" Monoid] (coll [list \"List/\" Monad]) maybe [ident \"Ident/\" Codec]) meta (macro ast)) (.. [type \"\" Eq]))"} (do Monad [#let [[_meta _imports] (: [(List [AST AST]) (List AST)] (case tokens (^ (list& [_ (#RecordS _meta)] _imports)) [_meta _imports] _ [(list) tokens]))] imports (parse-imports _imports) #let [=imports (map (: (-> Importation AST) (function [[m-name m-alias =refer]] (` [(~ (text$ m-name)) (~ (text$ (default "" m-alias)))]))) imports) =refers (map (: (-> Importation AST) (function [[m-name m-alias =refer]] (refer-to-ast m-name =refer))) imports)] =meta (process-def-meta (record$ (list& [(` #;imports) (` [(~@ =imports)])] _meta))) #let [=module (` (;_lux_module (~ =meta)))]] (wrap (#;Cons =module =refers)))) (macro: #export (:: tokens) {#;doc "## Allows accessing the value of a structure's member. (:: Codec encode) ## Also allows using that value as a function. (:: Codec encode 123)"} (case tokens (^ (list struct [_ (#SymbolS member)])) (return (list (` (let [(^open) (~ struct)] (~ (symbol$ member)))))) (^ (list& struct [_ (#SymbolS member)] args)) (return (list (` ((let [(^open) (~ struct)] (~ (symbol$ member))) (~@ args))))) _ (fail "Wrong syntax for ::"))) (macro: #export (set@ tokens) {#;doc "## Sets the value of a record at a given tag. (set@ #name \"Lux\" lang) ## Can also work with multiple levels of nesting: (set@ [#foo #bar #baz] value my-record) ## And, if only the slot/path and (optionally) the value are given, generates a ## mutator function: (let [setter (set@ [#foo #bar #baz] value)] (setter my-record)) (let [setter (set@ [#foo #bar #baz])] (setter value my-record))"} (case tokens (^ (list [_ (#TagS slot')] value record)) (do Monad [slot (normalize slot') output (resolve-tag slot) #let [[idx tags exported? type] output]] (case (resolve-struct-type type) (#Some members) (do Monad [pattern' (mapM Monad (: (-> [Ident [Nat Type]] (Lux [Ident Nat AST])) (function [[r-slot-name [r-idx r-type]]] (do Monad [g!slot (gensym "")] (return [r-slot-name r-idx g!slot])))) (zip2 tags (enumerate members)))] (let [pattern (record$ (map (: (-> [Ident Nat AST] [AST AST]) (function [[r-slot-name r-idx r-var]] [(tag$ r-slot-name) r-var])) pattern')) output (record$ (map (: (-> [Ident Nat AST] [AST AST]) (function [[r-slot-name r-idx r-var]] [(tag$ r-slot-name) (if (n.= idx r-idx) value r-var)])) pattern'))] (return (list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) _ (fail "set@ can only use records."))) (^ (list [_ (#TupleS slots)] value record)) (case slots #;Nil (fail "Wrong syntax for set@") _ (do Monad [bindings (mapM Monad (: (-> AST (Lux AST)) (function [_] (gensym "temp"))) slots) #let [pairs (zip2 slots bindings) update-expr (fold (: (-> [AST AST] AST AST) (function [[s b] v] (` (;;set@ (~ s) (~ v) (~ b))))) value (reverse pairs)) [_ accesses'] (fold (: (-> [AST AST] [AST (List (List AST))] [AST (List (List AST))]) (function [[new-slot new-binding] [old-record accesses']] [(` (get@ (~ new-slot) (~ new-binding))) (#;Cons (list new-binding old-record) accesses')])) [record (: (List (List AST)) #;Nil)] pairs) accesses (List/join (reverse accesses'))]] (wrap (list (` (let [(~@ accesses)] (~ update-expr))))))) (^ (list selector value)) (do Monad [g!record (gensym "record")] (wrap (list (` (function [(~ g!record)] (;;set@ (~ selector) (~ value) (~ g!record))))))) (^ (list selector)) (do Monad [g!value (gensym "value") g!record (gensym "record")] (wrap (list (` (function [(~ g!value) (~ g!record)] (;;set@ (~ selector) (~ g!value) (~ g!record))))))) _ (fail "Wrong syntax for set@"))) (macro: #export (update@ tokens) {#;doc "## Modifies the value of a record at a given tag, based on some function. (update@ #age i.inc person) ## Can also work with multiple levels of nesting: (update@ [#foo #bar #baz] func my-record) ## And, if only the slot/path and (optionally) the value are given, generates a ## mutator function: (let [updater (update@ [#foo #bar #baz] func)] (updater my-record)) (let [updater (update@ [#foo #bar #baz])] (updater func my-record))"} (case tokens (^ (list [_ (#TagS slot')] fun record)) (do Monad [slot (normalize slot') output (resolve-tag slot) #let [[idx tags exported? type] output]] (case (resolve-struct-type type) (#Some members) (do Monad [pattern' (mapM Monad (: (-> [Ident [Nat Type]] (Lux [Ident Nat AST])) (function [[r-slot-name [r-idx r-type]]] (do Monad [g!slot (gensym "")] (return [r-slot-name r-idx g!slot])))) (zip2 tags (enumerate members)))] (let [pattern (record$ (map (: (-> [Ident Nat AST] [AST AST]) (function [[r-slot-name r-idx r-var]] [(tag$ r-slot-name) r-var])) pattern')) output (record$ (map (: (-> [Ident Nat AST] [AST AST]) (function [[r-slot-name r-idx r-var]] [(tag$ r-slot-name) (if (n.= idx r-idx) (` ((~ fun) (~ r-var))) r-var)])) pattern'))] (return (list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) _ (fail "update@ can only use records."))) (^ (list [_ (#TupleS slots)] fun record)) (case slots #;Nil (fail "Wrong syntax for update@") _ (do 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 Monad [g!record (gensym "record")] (wrap (list (` (function [(~ g!record)] (;;update@ (~ selector) (~ fun) (~ g!record))))))) (^ (list selector)) (do Monad [g!fun (gensym "fun") g!record (gensym "record")] (wrap (list (` (function [(~ g!fun) (~ g!record)] (;;update@ (~ selector) (~ g!fun) (~ g!record))))))) _ (fail "Wrong syntax for update@"))) (macro: #export (^template tokens) {#;doc "## It's similar to do-template, but meant to be used during pattern-matching. (def: (beta-reduce env type) (-> (List Type) Type Type) (case type (#;HostT name params) (#;HostT name (List/map (beta-reduce env) params)) (^template [] ( left right) ( (beta-reduce env left) (beta-reduce env right))) ([#;SumT] [#;ProdT]) (^template [] ( left right) ( (beta-reduce env left) (beta-reduce env right))) ([#;FunctionT] [#;AppT]) (^template [] ( old-env def) (case old-env #;Nil ( env def) _ type)) ([#;UnivQ] [#;ExQ]) (#;BoundT idx) (default type (list;nth idx env)) _ type ))"} (case tokens (^ (list& [_ (#FormS (list& [_ (#TupleS bindings)] templates))] [_ (#FormS data)] branches)) (case (: (Maybe (List AST)) (do Monad [bindings' (mapM Monad get-name bindings) data' (mapM Monad tuple->list data)] (if (every? (i.= (length bindings')) (map length data')) (let [apply (: (-> RepEnv (List AST)) (function [env] (map (apply-template env) templates)))] (|> data' (join-map (. apply (make-env bindings'))) wrap)) #;None))) (#Some output) (return (List/append output branches)) #None (fail "Wrong syntax for ^template")) _ (fail "Wrong syntax for ^template"))) (do-template [ ] [(def: #export ( n) (-> ) (_lux_proc [n]))] [real-to-int Real Int ["real" "to-int"]] [int-to-real Int Real ["int" "to-real"]] ) (def: (find-baseline-column ast) (-> AST Nat) (case ast (^template [] [[_ _ column] ( _)] column) ([#BoolS] [#NatS] [#IntS] [#DegS] [#RealS] [#CharS] [#TextS] [#SymbolS] [#TagS]) (^template [] [[_ _ column] ( parts)] (fold n.min column (map find-baseline-column parts))) ([#FormS] [#TupleS]) [[_ _ column] (#RecordS pairs)] (fold n.min column (List/append (map (. find-baseline-column first) pairs) (map (. find-baseline-column second) pairs))) )) (type: Doc-Fragment (#Doc-Comment Text) (#Doc-Example AST)) (def: (identify-doc-fragment ast) (-> AST Doc-Fragment) (case ast [_ (#;TextS comment)] (#Doc-Comment comment) _ (#Doc-Example ast))) (def: (Text/encode original) (-> Text Text) (let [escaped (|> original (replace-all "\t" "\\t") (replace-all "\v" "\\v") (replace-all "\b" "\\b") (replace-all "\n" "\\n") (replace-all "\r" "\\r") (replace-all "\f" "\\f") (replace-all "\"" "\\\"") (replace-all "\\" "\\\\") )] ($_ Text/append "\"" escaped "\""))) (do-template [ ] [(def: #export ( value) {#;doc } (-> ) ( value))] [i.inc i.+ 1 Int "[Int] Increment function."] [i.dec i.- 1 Int "[Int] Decrement function."] [n.inc n.+ +1 Nat "[Nat] Increment function."] [n.dec n.- +1 Nat "[Nat] Decrement function."] ) (def: Tag/encode (-> Ident Text) (. (Text/append "#") Ident/encode)) (do-template [ ] [(def: #export ( input) (-> ) (_lux_proc [input]))] [int-to-nat ["int" "to-nat"] Int Nat] [nat-to-int ["nat" "to-int"] Nat Int] [real-to-deg ["real" "to-deg"] Real Deg] [deg-to-real ["deg" "to-real"] Deg Real] ) (def: (repeat n x) (All [a] (-> Int a (List a))) (if (i.> 0 n) (#;Cons x (repeat (i.+ -1 n) x)) #;Nil)) (def: (cursor-padding baseline [_ old-line old-column] [_ new-line new-column]) (-> Nat Cursor Cursor Text) (if (n.= old-line new-line) (Text/join (repeat (nat-to-int (n.- old-column new-column)) " ")) (let [extra-lines (Text/join (repeat (nat-to-int (n.- old-line new-line)) "\n")) space-padding (Text/join (repeat (nat-to-int (n.- baseline new-column)) " "))] (Text/append extra-lines space-padding)))) (def: (Text/size x) (-> Text Nat) (_lux_proc ["text" "size"] [x])) (def: (Text/trim x) (-> Text Text) (_lux_proc ["text" "trim"] [x])) (def: (update-cursor [file line column] ast-text) (-> Cursor Text Cursor) [file line (n.+ column (Text/size ast-text))]) (def: (delim-update-cursor [file line column]) (-> Cursor Cursor) [file line (n.inc column)]) (def: rejoin-all-pairs (-> (List [AST AST]) (List AST)) (. List/join (map rejoin-pair))) (def: (doc-example->Text prev-cursor baseline example) (-> Cursor Nat AST [Cursor Text]) (case example (^template [ ] [new-cursor ( value)] (let [as-text ( value)] [(update-cursor new-cursor as-text) (Text/append (cursor-padding baseline prev-cursor new-cursor) as-text)])) ([#BoolS Bool/encode] [#NatS Nat/encode] [#IntS Int/encode] [#DegS Deg/encode] [#RealS Real/encode] [#CharS Char/encode] [#TextS Text/encode] [#SymbolS Ident/encode] [#TagS Tag/encode]) (^template [ ] [group-cursor ( parts)] (let [[group-cursor' parts-text] (fold (function [part [last-cursor text-accum]] (let [[part-cursor part-text] (doc-example->Text last-cursor baseline part)] [part-cursor (Text/append text-accum part-text)])) [(delim-update-cursor group-cursor) ""] ( parts))] [(delim-update-cursor group-cursor') ($_ Text/append (cursor-padding baseline prev-cursor group-cursor) parts-text )])) ([#FormS "(" ")" id] [#TupleS "[" "]" id] [#RecordS "{" "}" rejoin-all-pairs]) )) (def: (with-baseline baseline [file line column]) (-> Nat Cursor Cursor) [file line baseline]) (def: (doc-fragment->Text fragment) (-> Doc-Fragment Text) (case fragment (#Doc-Comment comment) (|> comment (split-text "\n") (map (function [line] ($_ Text/append "## " line "\n"))) Text/join) (#Doc-Example example) (let [baseline (find-baseline-column example) [cursor _] example [_ text] (doc-example->Text (with-baseline baseline cursor) baseline example)] (Text/append text "\n\n")))) (macro: #export (doc tokens) {#;doc "## Creates code documentation, embedding text as comments and properly formatting the forms it's being given. ## For Example: (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 (i.inc count) (f x)) x)))"} (return (list (` (#;TextA (~ (|> tokens (map (. doc-fragment->Text identify-doc-fragment)) Text/join Text/trim 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-ast type) (-> Type AST) (case type (#HostT name params) (` (#HostT (~ (text$ name)) (~ (untemplate-list (map type-to-ast params))))) #VoidT (` #VoidT) #UnitT (` #UnitT) (^template [] ( left right) (` ( (~ (type-to-ast left)) (~ (type-to-ast right))))) ([#SumT] [#ProdT]) (#FunctionT in out) (` (#FunctionT (~ (type-to-ast in)) (~ (type-to-ast out)))) (#BoundT idx) (` (#BoundT (~ (nat$ idx)))) (#VarT id) (` (#VarT (~ (nat$ id)))) (#ExT id) (` (#ExT (~ (nat$ id)))) (#UnivQ env type) (let [env' (untemplate-list (map type-to-ast env))] (` (#UnivQ (~ env') (~ (type-to-ast type))))) (#ExQ env type) (let [env' (untemplate-list (map type-to-ast env))] (` (#ExQ (~ env') (~ (type-to-ast type))))) (#AppT fun arg) (` (#AppT (~ (type-to-ast fun)) (~ (type-to-ast arg)))) (#NamedT [module name] type) (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type-to-ast type)))) )) (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 (i.inc count) (f x)) x)))} (case tokens (^ (list [_ (#TupleS bindings)] body)) (let [pairs (as-pairs bindings) vars (map first pairs) inits (map second pairs)] (if (every? symbol? inits) (do Monad [inits' (: (Lux (List Ident)) (case (mapM Monad get-ident inits) (#Some inits') (return inits') #None (fail "Wrong syntax for loop"))) init-types (mapM Monad find-type inits') expected get-expected-type] (return (list (` ((;_lux_: (-> (~@ (map type-to-ast init-types)) (~ (type-to-ast expected))) (function (~ (symbol$ ["" "recur"])) [(~@ vars)] (~ body))) (~@ inits)))))) (do Monad [aliases (mapM Monad (: (-> AST (Lux AST)) (function [_] (gensym ""))) inits)] (return (list (` (let [(~@ (interleave aliases inits))] (;loop [(~@ (interleave vars aliases))] (~ body))))))))) _ (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& [_ (#FormS (list [_ (#TupleS (list& hslot' tslots'))]))] body branches)) (do Monad [slots (: (Lux [Ident (List Ident)]) (case (: (Maybe [Ident (List Ident)]) (do Monad [hslot (get-tag hslot') tslots (mapM 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 (mapM Monad normalize tslots) output (resolve-tag hslot) g!_ (gensym "_") #let [[idx tags exported? type] output slot-pairings (map (: (-> Ident [Text AST]) (function [[module name]] [name (symbol$ ["" name])])) (list& hslot tslots)) pattern (record$ (map (: (-> Ident [AST AST]) (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 AST) AST (Maybe (List AST))) (case target (^or [_ (#BoolS _)] [_ (#NatS _)] [_ (#IntS _)] [_ (#DegS _)] [_ (#RealS _)] [_ (#CharS _)] [_ (#TextS _)] [_ (#TagS _)]) (#Some (list target)) [_ (#SymbolS [prefix name])] (if (and (Text/= "" prefix) (Text/= label name)) (#Some tokens) (#Some (list target))) (^template [ ] [_ ( elems)] (do Monad [placements (mapM Monad (place-tokens label tokens) elems)] (wrap (list ( (List/join placements)))))) ([#TupleS tuple$] [#FormS form$]) [_ (#RecordS pairs)] (do Monad [=pairs (mapM Monad (: (-> [AST AST] (Maybe [AST AST])) (function [[slot value]] (do 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 (record$ =pairs)))) )) (macro: #export (let% tokens) {#;doc (doc "Controlled macro-expansion." "Bind an arbitraty number of ASTs resulting from macro-expansion to local bindings." "Wherever a binding appears, the bound ASTs will be spliced in there." (test: "AST operations & structures" (let% [ (do-template [ ] [(compare ) (compare (:: AST/encode show )) (compare true (:: Eq = ))] [(bool true) "true" [_ (#;BoolS true)]] [(bool false) "false" [_ (#;BoolS false)]] [(int 123) "123" [_ (#;IntS 123)]] [(real 123.0) "123.0" [_ (#;RealS 123.0)]] [(char #"\n") "#\"\\n\"" [_ (#;CharS #"\n")]] [(text "\n") "\"\\n\"" [_ (#;TextS "\n")]] [(tag ["yolo" "lol"]) "#yolo;lol" [_ (#;TagS ["yolo" "lol"])]] [(symbol ["yolo" "lol"]) "yolo;lol" [_ (#;SymbolS ["yolo" "lol"])]] [(form (list (bool true) (int 123))) "(true 123)" (^ [_ (#;FormS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])] [(tuple (list (bool true) (int 123))) "[true 123]" (^ [_ (#;TupleS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])] [(record (list [(bool true) (int 123)])) "{true 123}" (^ [_ (#;RecordS (list [[_ (#;BoolS true)] [_ (#;IntS 123)]]))])] [(local-tag "lol") "#lol" [_ (#;TagS ["" "lol"])]] [(local-symbol "lol") "lol" [_ (#;SymbolS ["" "lol"])]] )] (test-all ))))} (case tokens (^ (list& [_ (#TupleS bindings)] bodies)) (case bindings (^ (list& [_ (#SymbolS ["" var-name])] macro-expr bindings')) (do Monad [expansion (macro-expand-once macro-expr)] (case (place-tokens var-name expansion (` (;let% [(~@ bindings')] (~@ bodies)))) (#Some output) (wrap output) _ (fail "[let%] Improper macro expansion."))) #Nil (return bodies) _ (fail "Wrong syntax for let%")) _ (fail "Wrong syntax for let%"))) (def: (flatten-alias type) (-> Type Type) (case type (^template [] (#NamedT ["lux" ] _) type) (["Bool"] ["Nat"] ["Int"] ["Deg"] ["Real"] ["Char"] ["Text"]) (#NamedT _ type') type' _ type)) (def: (anti-quote-def name) (-> Ident (Lux AST)) (do Monad [type+value (find-def-value name) #let [[type value] type+value]] (case (flatten-alias type) (^template [ ] (#NamedT ["lux" ] _) (wrap ( (:! value)))) (["Bool" Bool bool$] ["Nat" Nat nat$] ["Int" Int int$] ["Deg" Deg deg$] ["Real" Real real$] ["Char" Char char$] ["Text" Text text$]) _ (fail (Text/append "Cannot anti-quote type: " (Ident/encode name)))))) (def: (anti-quote token) (-> AST (Lux AST)) (case token [_ (#SymbolS [def-prefix def-name])] (if (Text/= "" def-prefix) (:: Monad return token) (anti-quote-def [def-prefix def-name])) (^template [] [meta ( parts)] (do Monad [=parts (mapM Monad anti-quote parts)] (wrap [meta ( =parts)]))) ([#FormS] [#TupleS]) [meta (#RecordS pairs)] (do Monad [=pairs (mapM Monad (: (-> [AST AST] (Lux [AST AST])) (function [[slot value]] (do Monad [=value (anti-quote value)] (wrap [slot =value])))) pairs)] (wrap [meta (#RecordS =pairs)])) _ (:: Monad return token) )) (macro: #export (^~ tokens) {#;doc (doc "Use global defs with simple values, such as text, int, real, bool and char, in place of literals in patterns." "The definitions must be properly-qualified (though you may use one of the short-cuts Lux provides)." (def: (empty?' node) (All [K V] (-> (Node K V) Bool)) (case node (^~ (#Base ;;clean-bitmap _)) true _ false)))} (case tokens (^ (list& [_ (#FormS (list pattern))] body branches)) (do Monad [module-name current-module-name pattern+ (macro-expand-all pattern)] (case pattern+ (^ (list pattern')) (do Monad [pattern'' (anti-quote pattern')] (wrap (list& pattern'' body branches))) _ (fail "^~ can only expand to 1 pattern."))) _ (fail "Wrong syntax for ^~"))) (type: MultiLevelCase [AST (List [AST AST])]) (def: (case-level^ level) (-> AST (Lux [AST AST])) (case level (^ [_ (#;TupleS (list expr binding))]) (return [expr binding]) _ (return [level (` true)]) )) (def: (multi-level-case^ levels) (-> (List AST) (Lux MultiLevelCase)) (case levels #;Nil (fail "Multi-level patterns cannot be empty.") (#;Cons init extras) (do Monad [extras' (mapM Monad case-level^ extras)] (wrap [init extras'])))) (def: (multi-level-case$ g!_ [[init-pattern levels] body]) (-> AST [MultiLevelCase AST] (List AST)) (let [inner-pattern-body (fold (function [[calculation pattern] success] (` (case (~ calculation) (~ pattern) (~ success) (~ g!_) #;None))) (` (#;Some (~ body))) (: (List [AST AST]) (reverse levels)))] (list init-pattern inner-pattern-body))) (macro: #export (^=> 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) (^=> (#;Some [chunk uri']) [(Text/= static chunk) true]) (match-uri endpoint? parts' uri') _ (#;Left (format "Static part " (%t static) " does not match URI: " uri))) "Short-cuts can be taken when using boolean tests." "The example above can be rewritten as..." (case (split (size static) uri) (^=> (#;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 (#;FormS levels)] body next-branches)) (do Monad [mlc (multi-level-case^ levels) expected get-expected-type g!temp (gensym "temp")] (let [output (list g!temp (` (;_lux_case (;_lux_: (#;AppT Maybe (~ (type-to-ast expected))) (case (~ g!temp) (~@ (multi-level-case$ g!temp [mlc body])) (~ g!temp) #;None)) (#;Some (~ g!temp)) (~ g!temp) #;None (case (~ g!temp) (~@ next-branches)))))] (wrap output))) _ (fail "Wrong syntax for ^=>"))) (macro: #export (ident-for tokens) {#;doc (doc "Given a symbol or a tag, gives back a 2 tuple with the prefix and name parts, both as Text." (ident-for #;doc) "=>" ["lux" "doc"])} (case tokens (^template [] (^ (list [_ ( [prefix name])])) (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))) ([#;SymbolS] [#;TagS]) _ (fail "Wrong syntax for ident-for"))) (do-template [ <%> <=> <0> <2>] [(def: #export ( n) (-> Bool) (<=> <0> (<%> <2> n))) (def: #export ( n) (-> Bool) (not ( n)))] [Nat n.even? n.odd? n.% n.= +0 +2] [Int i.even? i.odd? i.% i.= 0 2]) (def: (get-scope-type-vars state) (Lux (List Nat)) (case state {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor #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 (n.= +0 idx) (#;Some x) (list-at (n.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) (Vector a))) (List/fold add (: (Vector ($ +0)) empty) list)))} (case tokens (^ (list [_ (#NatS idx)])) (do Monad [stvs get-scope-type-vars] (case (list-at idx (reverse stvs)) (#;Some var-id) (wrap (list (` (#ExT (~ (nat$ var-id)))))) #;None (fail (Text/append "Indexed-type does not exist: " (Nat/encode idx))))) _ (fail "Wrong syntax for $"))) (def: #export (is left right) {#;doc (doc "Tests whether the 2 values are identical (not just \"equal\")." "This one should succeed:" (let [value 5] (is 5 5)) "This one should fail:" (is 5 (i.+ 2 3)))} (All [a] (-> a a Bool)) (_lux_proc ["lux" "is"] [left right])) (macro: #export (^@ tokens) {#;doc (doc "Allows you to simultaneously bind and de-structure a value." (def: (hash (^@ set [Hash _])) (List/fold (function [elem acc] (n.+ (:: Hash hash elem) acc)) +0 (to-list set))))} (case tokens (^ (list& [_meta (#;FormS (list [_ (#;SymbolS ["" name])] pattern))] body branches)) (let [g!whole (symbol$ ["" name])] (return (list& g!whole (` (case (~ g!whole) (~ pattern) (~ body))) branches))) _ (fail "Wrong syntax for ^@"))) (macro: #export (^|> tokens) {#;doc (doc "Pipes the value being pattern-matched against prior to binding it to a variable." (case input (^|> value [n.inc (n.% +10) (n.max +1)]) (foo value)))} (case tokens (^ (list& [_meta (#;FormS (list [_ (#;SymbolS ["" name])] [_ (#;TupleS steps)]))] body branches)) (let [g!name (symbol$ ["" name])] (return (list& g!name (` (let [(~ g!name) (|> (~ g!name) (~@ steps))] (~ body))) branches))) _ (fail "Wrong syntax for ^|>"))) (macro: #export (:!! tokens) {#;doc (doc "Coerces the given expression to the type of whatever is expected." (: Dinosaur (:!! (list 1 2 3))))} (case tokens (^ (list expr)) (do Monad [type get-expected-type] (wrap (list (` (;_lux_:! (~ (type-to-ast type)) (~ expr)))))) _ (fail "Wrong syntax for :!!"))) (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." (def: (square x) (-> Int Int) (undefined)) "If an undefined expression is ever evaluated, it will raise an error.")} (case tokens #;Nil (return (list (` (error! "Undefined behavior.")))) _ (fail "Wrong syntax for undefined"))) (macro: #export (type-of tokens) {#;doc (doc "Generates the type corresponding to a given definition or variable." (let [my-num (: Int 123)] (type-of my-num)) "==" Int)} (case tokens (^ (list [_ (#;SymbolS var-name)])) (do Monad [var-type (find-type var-name)] (wrap (list (type-to-ast var-type)))) _ (fail "Wrong syntax for type-of"))) (type: #hidden Export-Level' #Export #Hidden) (def: (parse-export-level tokens) (-> (List AST) (Lux [(Maybe Export-Level') (List AST)])) (case tokens (^ (list& [_ (#TagS ["" "export"])] tokens')) (:: Monad wrap [(#;Some #Export) tokens']) (^ (list& [_ (#TagS ["" "hidden"])] tokens')) (:: Monad wrap [(#;Some #Hidden) tokens']) _ (:: Monad wrap [#;None tokens]) )) (def: (gen-export-level ?export-level) (-> (Maybe Export-Level') (List AST)) (case ?export-level #;None (list) (#;Some #Export) (list (' #export)) (#;Some #Hidden) (list (' #hidden)) )) (def: (parse-complex-declaration tokens) (-> (List AST) (Lux [[Text (List Text)] (List AST)])) (case tokens (^ (list& [_ (#FormS (list& [_ (#SymbolS ["" name])] args'))] tokens')) (do Monad [args (mapM Monad (function [arg'] (case arg' [_ (#SymbolS ["" 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 AST) (Lux [AST (List AST)])) (case tokens (^ (list& token tokens')) (:: Monad wrap [token tokens']) _ (fail "Could not parse anything.") )) (def: (parse-end tokens) (-> (List AST) (Lux Unit)) (case tokens (^ (list)) (:: Monad wrap []) _ (fail "Expected input ASTs to be empty.") )) (def: (parse-anns tokens) (-> (List AST) (Lux [AST (List AST)])) (case tokens (^ (list& [_ (#RecordS _anns)] tokens')) (:: Monad wrap [(record$ _anns) tokens']) _ (:: Monad wrap [(' {}) tokens]) )) (macro: #export (template: tokens) {#;doc (doc "Define macros in the style of do-template and ^template." "For simple macros that do not need any fancy features." (template: (square x) (i.* x x)))} (do Monad [?export-level|tokens (parse-export-level tokens) #let [[?export-level tokens] ?export-level|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-template|tokens (parse-any tokens) #let [[input-template tokens] input-template|tokens] _ (parse-end tokens) g!tokens (gensym "tokens") g!compiler (gensym "compiler") g!_ (gensym "_") #let [rep-env (map (function [arg] [arg (` ((~' ~) (~ (symbol$ ["" arg]))))]) args)]] (wrap (list (` (macro: (~@ (gen-export-level ?export-level)) ((~ (symbol$ ["" name])) (~ g!tokens) (~ g!compiler)) (~ anns) (case (~ g!tokens) (^ (list (~@ (map (|>. [""] symbol$) args)))) (#;Right [(~ g!compiler) (list (` (~ (replace-syntax rep-env input-template))))]) (~ g!_) (#;Left (~ (text$ (Text/append "Wrong syntax for " name)))) ))))) )) (def: #export (assume mx) (All [a] (-> (Maybe a) a)) (default (undefined) mx))