## Basic types (_lux_def Bool (+12 ["lux" "Bool"] (+0 "java.lang.Boolean" (+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 "java.lang.Long" (+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 "java.lang.Double" (+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 "java.lang.Character" (+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 "java.lang.String" (+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 can't 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) ## (#LambdaT 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;LambdaT" 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 "LambdaT") (#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 doesn't 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 Int ## #column Int}) (_lux_def Cursor (#NamedT ["lux" "Cursor"] (#ProdT Text (#ProdT Int Int))) (#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 ## {#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 ## ) (_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)))) ## "lux;module-anns" Anns) )))))) (#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") #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-name Text ## #compiler-version Text ## #compiler-mode Compiler-Mode}) (_lux_def Compiler-Info (#NamedT ["lux" "Compiler-Info"] (#ProdT ## "lux;compiler-name" Text (#ProdT ## "lux;compiler-version" Text ## "lux;compiler-mode" Compiler-Mode))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "compiler-name") (#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 ## "lux;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 (#LambdaT 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"] (#LambdaT 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 ## (def: _cursor ## Cursor ## ["" -1 -1]) (_lux_def _cursor (_lux_: Cursor ["" -1 -1]) #Nil) ## (def: (_meta data) ## (-> (AST' (Meta Cursor)) AST) ## [["" -1 -1] data]) (_lux_def _meta (_lux_: (#LambdaT (#AppT AST' (#AppT Meta Cursor)) AST) (_lux_lambda _ data [_cursor data])) #Nil) ## (def: (return x) ## (All [a] ## (-> a Compiler ## (Either Text [Compiler a]))) ## ...) (_lux_def return (_lux_: (#UnivQ #Nil (#LambdaT (#BoundT +1) (#LambdaT Compiler (#AppT (#AppT Either Text) (#ProdT Compiler (#BoundT +1)))))) (_lux_lambda _ val (_lux_lambda _ state (#Right state val)))) #Nil) ## (def: (fail msg) ## (All [a] ## (-> Text Compiler ## (Either Text [Compiler a]))) ## ...) (_lux_def fail (_lux_: (#UnivQ #Nil (#LambdaT Text (#LambdaT Compiler (#AppT (#AppT Either Text) (#ProdT Compiler (#BoundT +1)))))) (_lux_lambda _ msg (_lux_lambda _ state (#Left msg)))) #Nil) (_lux_def bool$ (_lux_: (#LambdaT Bool AST) (_lux_lambda _ value (_meta (#BoolS value)))) #Nil) (_lux_def nat$ (_lux_: (#LambdaT Nat AST) (_lux_lambda _ value (_meta (#NatS value)))) #Nil) (_lux_def int$ (_lux_: (#LambdaT Int AST) (_lux_lambda _ value (_meta (#IntS value)))) #Nil) (_lux_def deg$ (_lux_: (#LambdaT Deg AST) (_lux_lambda _ value (_meta (#DegS value)))) #Nil) (_lux_def real$ (_lux_: (#LambdaT Real AST) (_lux_lambda _ value (_meta (#RealS value)))) #Nil) (_lux_def char$ (_lux_: (#LambdaT Char AST) (_lux_lambda _ value (_meta (#CharS value)))) #Nil) (_lux_def text$ (_lux_: (#LambdaT Text AST) (_lux_lambda _ text (_meta (#TextS text)))) #Nil) (_lux_def symbol$ (_lux_: (#LambdaT Ident AST) (_lux_lambda _ ident (_meta (#SymbolS ident)))) #Nil) (_lux_def tag$ (_lux_: (#LambdaT Ident AST) (_lux_lambda _ ident (_meta (#TagS ident)))) #Nil) (_lux_def form$ (_lux_: (#LambdaT (#AppT List AST) AST) (_lux_lambda _ tokens (_meta (#FormS tokens)))) #Nil) (_lux_def tuple$ (_lux_: (#LambdaT (#AppT List AST) AST) (_lux_lambda _ tokens (_meta (#TupleS tokens)))) #Nil) (_lux_def record$ (_lux_: (#LambdaT (#AppT List (#ProdT AST AST)) AST) (_lux_lambda _ 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_lambda _ 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 lambda'' (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) (#Cons (_meta (#SymbolS "" "")) (#Cons arg (#Cons (_lux_case args' #Nil body _ (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''")) (#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_lambda")) (#Cons (_meta (#SymbolS "" self)) (#Cons arg (#Cons (_lux_case args' #Nil body _ (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''")) (#Cons (_meta (#TupleS args')) (#Cons body #Nil)))))) #Nil)))))) #Nil)) _ (fail "Wrong syntax for lambda''")))) 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_: (#LambdaT AST AST) (lambda'' [tail] (form$ (#Cons (tag$ ["lux" "Cons"]) (#Cons export?-meta (#Cons tail #Nil)))))) #Nil) (_lux_def with-hidden-meta (_lux_: (#LambdaT AST AST) (lambda'' [tail] (form$ (#Cons (tag$ ["lux" "Cons"]) (#Cons hidden?-meta (#Cons tail #Nil)))))) #Nil) (_lux_def with-macro-meta (_lux_: (#LambdaT AST AST) (lambda'' [tail] (form$ (#Cons (tag$ ["lux" "Cons"]) (#Cons macro?-meta (#Cons tail #Nil)))))) #Nil) (_lux_def def:'' (_lux_: Macro (lambda'' [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" "lambda''"])) (#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" "lambda''"])) (#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 (#LambdaT (#LambdaT (#BoundT +3) (#BoundT +1)) (#LambdaT ($' 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 (#LambdaT ($' List Text) (#LambdaT ($' 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 (#LambdaT Text (#LambdaT Text Bool)) (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [x y])) (def:'' (get-rep key env) #Nil (#LambdaT Text (#LambdaT 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 (#LambdaT RepEnv (#LambdaT 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_: (#LambdaT (#ProdT AST AST) (#ProdT AST AST)) (lambda'' [slot] (_lux_case slot [k v] [(replace-syntax reps k) (replace-syntax reps v)]))) slots))] _ syntax) ) (def:'' (update-bounds ast) #Nil (#LambdaT AST AST) (_lux_case ast [_ (#TupleS members)] (tuple$ (map update-bounds members)) [_ (#RecordS pairs)] (record$ (map (_lux_: (#LambdaT (#ProdT AST AST) (#ProdT AST AST)) (lambda'' [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))) (#LambdaT ($' List AST) (#LambdaT (#LambdaT ($' 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' (lambda'' [names] (next (#Cons arg-name names)))) _ (fail "Expected symbol.") )) (def:'' (make-bound idx) #Nil (#LambdaT 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 (#LambdaT (#LambdaT (#BoundT +1) (#LambdaT (#BoundT +3) (#BoundT +3))) (#LambdaT (#BoundT +3) (#LambdaT ($' 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 (#LambdaT ($' List (#BoundT +1)) Int)) (fold (lambda'' [_ acc] (_lux_proc ["jvm" "ladd"] [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 (lambda'' [names] (let'' body' (fold (_lux_: (#LambdaT Text (#LambdaT AST AST)) (lambda'' [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 (lambda'' [names] (let'' body' (fold (_lux_: (#LambdaT Text (#LambdaT AST AST)) (lambda'' [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] (#LambdaT ($' List a) ($' List a))) (fold (lambda'' [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_: (#LambdaT AST (#LambdaT AST AST)) (lambda'' [i o] (form$ (#Cons (tag$ ["lux" "LambdaT"]) (#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 (lambda'' [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 (lambda'' [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 (lambda'' [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 (lambda'' [left right] (form$ (list (tag$ ["lux" "SumT"]) left right))) last prevs))) )) (macro:' (lambda' 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 "lambda' requires a non-empty arguments tuple.") (#Cons [harg targs]) (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) (symbol$ ["" name]) harg (fold (lambda'' [arg body'] (form$ (list (symbol$ ["" "_lux_lambda"]) (symbol$ ["" ""]) arg body'))) body (reverse targs))))))) _ (fail "Wrong syntax for lambda'")))) (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" "lambda'"]) 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" "lambda'"]) 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) (lambda' [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$ "") (int$ -1) (int$ -1))) 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 (lambda' [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 (lambda' [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 (lambda' return [x] (#Some x)) #bind (lambda' [f ma] (_lux_case ma #None #None (#Some a) (f a)))}) (def:''' Monad #Nil ($' Monad Lux) {#wrap (lambda' [x] (lambda' [state] (#Right state x))) #bind (lambda' [f ma] (lambda' [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) (lambda' [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_lambda"]) (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:''' (Text/append x y) #Nil (-> Text Text Text) (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [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 _}) (_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)) (lambda' [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)) (lambda' [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 "Can't 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) (lambda [(~@ 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) (lambda [(~@ 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 ->Text) (interpose \" \") (fold Text/append \"\")) ## => (fold Text/append \"\" (interpose \" \" (map ->Text elems)))")]) (_lux_case tokens (#Cons [init apps]) (return (list (fold (_lux_: (-> AST AST AST) (lambda' [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 ->Text) elems) ## => (fold Text/append \"\" (interpose \" \" (map ->Text elems)))")]) (_lux_case (reverse tokens) (#Cons [init apps]) (return (list (fold (_lux_: (-> AST AST AST) (lambda' [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))) (lambda' [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)) (lambda' [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 (lambda' [_2 _1] (if _1 (p _2) false)) true xs)) (def:''' (i= x y) #Nil (-> Int Int Bool) (_lux_proc ["jvm" "leq"] [x y])) (def:''' (->Text x) #Nil (-> (host java.lang.Object) Text) (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x])) (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)) (lambda' [env] (map (apply-template env) templates))) num-bindings (length bindings')] (if (every? (i= num-bindings) (map length data')) (|> data' (join-map (. apply (make-env bindings'))) return) (fail (Text/append "Irregular arguments vectors for do-template. Expected size " (->Text num-bindings))))) _ (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 "jvm" i.= "leq" i.< i.<= "llt" 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 "jvm" r.= "deq" r.< r.<= "dlt" 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.+ ["jvm" "ladd"] "Int(eger) addition."] [ Int i.- ["jvm" "lsub"] "Int(eger) substraction."] [ Int i.* ["jvm" "lmul"] "Int(eger) multiplication."] [ Int i./ ["jvm" "ldiv"] "Int(eger) division."] [ Int i.% ["jvm" "lrem"] "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.+ ["jvm" "dadd"] "Real addition."] [Real r.- ["jvm" "dsub"] "Real substraction."] [Real r.* ["jvm" "dmul"] "Real multiplication."] [Real r./ ["jvm" "ddiv"] "Real division."] [Real r.% ["jvm" "drem"] "Real remainder."] ) (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:''' (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 _} (_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] (lambda' [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 (lambda' [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) (lambda' [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])) (lambda' [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])) (lambda' [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 (->Text 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 it's 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))))]) 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) (lambda' [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 _ (` (lambda' (~ 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:''' (Nat->Text x) #Nil (-> Nat Text) (_lux_proc ["nat" "encode"] [x])) (def:''' (Deg->Text x) #Nil (-> Deg Text) (_lux_proc ["deg" "encode"] [x])) (def:' (ast-to-text ast) (-> AST Text) (_lux_case ast [_ (#BoolS value)] (->Text value) [_ (#NatS value)] (Nat->Text value) [_ (#IntS value)] (->Text value) [_ (#DegS value)] (Deg->Text value) [_ (#RealS value)] (->Text value) [_ (#CharS value)] ($_ Text/append "#" "\"" (->Text 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 (lambda' [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 can't have 0 patterns") _ (let' [pairs (|> patterns (map (lambda' [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) (lambda' [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 (lambda 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)) (lambda [x y] x)) (: (All [a b] (-> a b a)) (lambda 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) (lambda' [arg body'] (if (symbol? arg) (` (;_lux_lambda (~ g!blank) (~ arg) (~ body'))) (` (;_lux_lambda (~ g!blank) (~ g!blank) (case (~ g!blank) (~ arg) (~ body'))))))) body (reverse tail))] (return (list (if (symbol? head) (` (;_lux_lambda (~ g!name) (~ head) (~ body+))) (` (;_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) #None (fail "Wrong syntax for lambda"))) (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)) (lambda [[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)) (lambda [[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 (lambda [arg] (` (#;TextA (~ (text$ (ast-to-text arg)))))) args))))] (~ meta))))) (def:' (with-type-args args) (-> (List AST) AST) (` {#;type-args (#;ListA (list (~@ (map (lambda [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)))) (def:''' #export (log! message) (list [["lux" "doc"] (#TextA "Logs message to standard output. Useful for debugging.")]) (-> Text Unit) (_lux_proc ["jvm" "invokevirtual:java.io.PrintStream:println:java.lang.String"] [(_lux_proc ["jvm" "getstatic:java.lang.System:out"] []) message])) (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 _ (` (lambda (~ 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])) (lambda [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]) (lambda [[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)))) (def: (last-index-of part text) (-> Text Text Int) (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:lastIndexOf:java.lang.String"] [text part])])) (def: (index-of part text) (-> Text Text Int) (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:indexOf:java.lang.String"] [text part])])) (def: (substring1 idx text) (-> Int Text Text) (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int"] [text (_lux_proc ["jvm" "l2i"] [idx])])) (def: (substring2 idx1 idx2 text) (-> Int Int Text Text) (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] [text (_lux_proc ["jvm" "l2i"] [idx1]) (_lux_proc ["jvm" "l2i"] [idx2])])) (def: (split-text splitter input) (-> Text Text (List Text)) (let [idx (index-of splitter input)] (if (i.< 0 idx) (#Cons input #Nil) (#Cons (substring2 0 idx input) (split-text splitter (substring1 (i.+ 1 idx) input)))))) (def: (split-module-contexts module) (-> Text (List Text)) (#Cons module (let [idx (last-index-of "/" module)] (if (i.< 0 idx) #Nil (split-module-contexts (substring2 0 idx module)))))) (def: (split-module module) (-> Text (List Text)) (let [idx (index-of "/" module)] (if (i.< 0 idx) (list module) (list& (substring2 0 idx module) (split-module (substring1 (i.+ 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) (#LambdaT ?input ?output) (#LambdaT (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 #;LambdaT] [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)) (lambda [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]] (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]] (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) (lambda [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 (lambda [tag] [(second tag) (tag$ tag)]) tags))] members (mapM Monad (: (-> AST (Lux [AST AST])) (lambda [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 (lambda [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) (lambda [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) (lambda' [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)) (lambda [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) (lambda [part] (case part (^or [_ (#TextS _)] [_ (#SymbolS _)]) true _ false)))) (fold (lambda [r l] (and l r)) true)) (let [openings (fold (: (-> AST (List Openings) (List Openings)) (lambda [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) (lambda [part] (case part (^or [_ (#TextS _)] [_ (#SymbolS _)]) true _ false)))) (fold (lambda [r l] (and l r)) true)) (let [openings (fold (: (-> AST (List Openings) (List Openings)) (lambda [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) (lambda [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 pattern value template) (-> Text Text Text Text) (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value])) (def: (clean-module module) (-> Text (Lux Text)) (do Monad [module-name current-module-name] (case (split-module module) (^ (list& "." parts)) (return (|> (list& module-name 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 module-name)) #None (fail (Text/append "Can't 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))) (lambda [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 ";" 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)) (lambda [[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] 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 (lambda [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)) (lambda [env] (case env {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} (try-both (find (: (-> [Text Analysis] (Maybe Type)) (lambda [[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 _}) (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 _}) (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] (lambda [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: (use-field prefix [module name] type) (-> Text Ident Type (Lux [AST AST])) (do Monad [output (resolve-type-tags type) pattern (: (Lux AST) (case output (#Some [tags members]) (do Monad [slots (mapM Monad (: (-> [Ident Type] (Lux [AST AST])) (lambda [[sname stype]] (use-field prefix sname stype))) (zip2 tags members))] (return (record$ slots))) #None (return (symbol$ ["" (Text/append prefix name)]))))] (return [(tag$ [module name]) pattern]))) (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 "")) "]") (#LambdaT _) ($_ Text/append "(-> " (|> (flatten-lambda type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")") (#BoundT id) (Nat->Text id) (#VarT id) ($_ Text/append "⌈v:" (->Text id) "⌋") (#ExT id) ($_ Text/append "⟨e:" (->Text 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) )) (macro: #hidden (^open' tokens) (case tokens (^ (list [_ (#SymbolS name)] [_ (#TextS prefix)] body)) (do Monad [struct-type (find-type name) output (resolve-type-tags struct-type)] (case output (#Some [tags members]) (do Monad [slots (mapM Monad (: (-> [Ident Type] (Lux [AST AST])) (lambda [[sname stype]] (use-field prefix sname stype))) (zip2 tags members)) #let [pattern (record$ slots)]] (return (list (` (;_lux_case (~ (symbol$ name)) (~ pattern) (~ body)))))) _ (fail (Text/append "Can only \"open\" structs: " (Type/show struct-type))))) _ (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) (lambda [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]) (lambda [[[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) (lambda [slot inner] (` (;;get@ (~ slot) (~ inner))))) record slots))) (^ (list selector)) (do Monad [g!record (gensym "record")] (wrap (list (` (lambda [(~ 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))) (lambda [[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))) (lambda [[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 ->Text) (interpose \" \") (fold Text/append \"\")) ## => (lambda [] (fold Text/append \"\" (interpose \" \" (map ->Text ))))"} (do Monad [g!arg (gensym "arg")] (return (list (` (lambda [(~ 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]] (wrap (is-member? imports import-name)))) (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 [["" -1 -1] (#;SymbolS ["" ""])]) code (` (case (~ maybe) (#;Some (~ g!temp)) (~ g!temp) #;None (~ else)))] (#;Right [state (list code)])) _ (#;Left "Wrong syntax for ?"))) (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))) (lambda [module-name all-defs referred-defs] (mapM Monad (: (-> Text (Lux Unit)) (lambda [_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))) (lambda [module-name all-defs referred-defs] (mapM Monad (: (-> Text (Lux Unit)) (lambda [_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) (lambda [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)) (lambda [[prefix structs]] (map (lambda [[_ 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 (lambda [[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) (lambda [[m-name m-alias =refer]] (` [(~ (text$ m-name)) (~ (text$ (default "" m-alias)))]))) imports) =refers (map (: (-> Importation AST) (lambda [[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])) (lambda [[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]) (lambda [[r-slot-name r-idx r-var]] [(tag$ r-slot-name) r-var])) pattern')) output (record$ (map (: (-> [Ident Nat AST] [AST AST]) (lambda [[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)) (lambda [_] (gensym "temp"))) slots) #let [pairs (zip2 slots bindings) update-expr (fold (: (-> [AST AST] AST AST) (lambda [[s b] v] (` (;;set@ (~ s) (~ v) (~ b))))) value (reverse pairs)) [_ accesses'] (fold (: (-> [AST AST] [AST (List (List AST))] [AST (List (List AST))]) (lambda [[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 (` (lambda [(~ g!record)] (;;set@ (~ selector) (~ value) (~ g!record))))))) (^ (list selector)) (do Monad [g!value (gensym "value") g!record (gensym "record")] (wrap (list (` (lambda [(~ 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])) (lambda [[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]) (lambda [[r-slot-name r-idx r-var]] [(tag$ r-slot-name) r-var])) pattern')) output (record$ (map (: (-> [Ident Nat AST] [AST AST]) (lambda [[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 (` (lambda [(~ g!record)] (;;update@ (~ selector) (~ fun) (~ g!record))))))) (^ (list selector)) (do Monad [g!fun (gensym "fun") g!record (gensym "record")] (wrap (list (` (lambda [(~ 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))) ([#;LambdaT] [#;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)) (lambda [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 ["jvm" ] [n]))] [real-to-int Real Int "d2l"] [int-to-real Int Real "l2d"] ) (def: (find-baseline-column ast) (-> AST Int) (case ast (^template [] [[_ _ column] ( _)] column) ([#BoolS] [#NatS] [#IntS] [#DegS] [#RealS] [#CharS] [#TextS] [#SymbolS] [#TagS]) (^template [] [[_ _ column] ( parts)] (fold i.min column (map find-baseline-column parts))) ([#FormS] [#TupleS]) [[_ _ column] (#RecordS pairs)] (fold i.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: (Char/encode x) (-> Char Text) (let [as-text (case x #"\t" "\\t" #"\b" "\\b" #"\n" "\\n" #"\r" "\\r" #"\f" "\\f" #"\"" "\\\"" #"\\" "\\\\" _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))] ($_ Text/append "#\"" as-text "\""))) (def: (Text/encode original) (-> Text Text) (let [escaped (|> original (replace "\t" "\\t") (replace "\b" "\\b") (replace "\n" "\\n") (replace "\r" "\\r") (replace "\f" "\\f") (replace "\"" "\\\"") (replace "\\" "\\\\") )] ($_ Text/append "\"" escaped "\""))) (do-template [ ] [(def: #export ( value) {#;doc } (-> ) ( value))] [i.inc i.+ 1 Int "Increment function."] [i.dec i.- 1 Int "Decrement function."] [n.inc n.+ +1 Nat "Increment function."] [n.dec n.- +1 Nat "Decrement function."] ) (def: tag->Text (-> Ident Text) (. (Text/append "#") Ident/encode)) (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]) (-> Int Cursor Cursor Text) (if (i.= old-line new-line) (Text/join (repeat (i.- old-column new-column) " ")) (let [extra-lines (Text/join (repeat (i.- old-line new-line) "\n")) space-padding (Text/join (repeat (i.- baseline new-column) " "))] (Text/append extra-lines space-padding)))) (def: (Text/size x) (-> Text Int) (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])])) (def: (Text/trim x) (-> Text Text) (_lux_proc ["jvm" "invokevirtual:java.lang.String:trim:"] [x])) (def: (update-cursor [file line column] ast-text) (-> Cursor Text Cursor) [file line (i.+ column (Text/size ast-text))]) (def: (delim-update-cursor [file line column]) (-> Cursor Cursor) [file line (i.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 Int 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 ->Text] [#NatS Nat->Text] [#IntS ->Text] [#DegS Deg->Text] [#RealS ->Text] [#CharS Char/encode] [#TextS Text/encode] [#SymbolS Ident/encode] [#TagS tag->Text]) (^template [ ] [group-cursor ( parts)] (let [[group-cursor' parts-text] (fold (lambda [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]) (-> Int Cursor Cursor) [file line baseline]) (def: (doc-fragment->Text fragment) (-> Doc-Fragment Text) (case fragment (#Doc-Comment comment) (|> comment (split-text "\n") (map (lambda [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]) (#LambdaT in out) (` (#LambdaT (~ (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))) (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] (~ body))) (~@ inits)))))) (do Monad [aliases (mapM Monad (: (-> AST (Lux AST)) (lambda [_] (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]) (lambda [[module name]] [name (symbol$ ["" name])])) (list& hslot tslots)) pattern (record$ (map (: (-> Ident [AST AST]) (lambda [[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])) (lambda [[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" [["" -1 -1] (#;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 "Can't 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])) (lambda [[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 can't 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 (lambda [[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) " doesn't 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) " doesn't 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 doesn't exist: " (->Text 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" "=="] [left right])) (macro: #export (^@ tokens) {#;doc (doc "Allows you to simultaneously bind and de-structure a value." (def: (hash (^@ set [Hash _])) (List/fold (lambda [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 :!!"))) (def: #export (error! message) {#;doc (doc "Causes an error, with the given error message." (error! "OH NO!"))} (-> Text Bottom) (_lux_proc ["jvm" "throw"] [(_lux_proc ["jvm" "new:java.lang.Error:java.lang.String"] [message])])) (def: #hidden hack_Text/append (-> Text Text Text) Text/append) (def: get-cursor (Lux Cursor) (lambda [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] (#;Right [state cursor])))) (macro: #export (with-cursor tokens) {#;doc (doc "Given some text, appends to it a prefix for identifying where the text comes from." "For example:" (with-cursor (format "User: " user-id)) "Would be the same as:" (format "[the-module,the-line,the-column] " (format "User: " user-id)))} (case tokens (^ (list message)) (do Monad [cursor get-cursor] (let [[module line column] cursor cursor-prefix ($_ hack_Text/append "[" module "," (->Text line) "," (->Text column) "] ")] (wrap (list (` (hack_Text/append (~ (text$ cursor-prefix)) (~ message))))))) _ (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! (with-cursor "Undefined behavior."))))) _ (fail "Wrong syntax for undefined"))) (macro: #export (@pre tokens) {#;doc (doc "Pre-conditions." "Given a test and an expression to run, only runs the expression if the test passes." "Otherwise, an error is raised." (@pre (i.= 4 (i.+ 2 2)) (foo 123 456 789)))} (case tokens (^ (list test expr)) (return (list (` (if (~ test) (~ expr) (error! (with-cursor (~ (text$ (Text/append "Pre-condition failed: " (ast-to-text test)))))))))) _ (fail "Wrong syntax for @pre"))) (macro: #export (@post tokens) {#;doc (doc "Post-conditions." "Given a predicate and an expression to run, evaluates the expression and then tests the output with the predicate." "If the predicate returns true, returns the value of the expression." "Otherwise, an error is raised." (@post i.even? (i.+ 2 2)))} (case tokens (^ (list test expr)) (do Monad [g!output (gensym "")] (wrap (list (` (let [(~ g!output) (~ expr)] (if ((~ test) (~ g!output)) (~ g!output) (error! (with-cursor (~ (text$ (Text/append "Post-condition failed: " (ast-to-text test)))))))))))) _ (fail "Wrong syntax for @post"))) (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] ) (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 (lambda [arg'] (case arg' [_ (#SymbolS ["" arg-name])] (wrap arg-name) _ (fail "Couldn't parse an argument."))) args')] (wrap [[name args] tokens'])) _ (fail "Couldn't parse a complex declaration.") )) (def: (parse-any tokens) (-> (List AST) (Lux [AST (List AST)])) (case tokens (^ (list& token tokens')) (:: Monad wrap [token tokens']) _ (fail "Couldn't 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 don't 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 (lambda [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)))) ))))) )) (type: #export (<&> f g) (All [a] (& (f a) (g a)))) (type: #export (<|> f g) (All [a] (| (f a) (g a)))) (type: #export (<.> f g) (All [a] (f (g a))))