diff options
author | Eduardo Julian | 2016-12-01 11:00:44 -0400 |
---|---|---|
committer | Eduardo Julian | 2016-12-01 11:00:44 -0400 |
commit | 7f66c54f4c9753b94dbf46ec50b8b16549daf324 (patch) | |
tree | 1b5b896cfba870a66a99a03315b09df842eb5737 /stdlib/source/lux.lux | |
parent | 9c30546af022f8fe36b73e7e93414257ff28ee75 (diff) |
- Collected the Lux compiler's repo, the Standard Library's, the Leiningen plugin's and the Emacs mode's into a big monorepo, to keep development unified.
Diffstat (limited to '')
-rw-r--r-- | stdlib/source/lux.lux | 5541 |
1 files changed, 5541 insertions, 0 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux new file mode 100644 index 000000000..2b66cdbe1 --- /dev/null +++ b/stdlib/source/lux.lux @@ -0,0 +1,5541 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +## Basic types +(_lux_def Bool + (+12 ["lux" "Bool"] + (+0 "java.lang.Boolean" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Nat + (+12 ["lux" "Nat"] + (+0 "#Nat" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Int + (+12 ["lux" "Int"] + (+0 "java.lang.Long" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Real + (+12 ["lux" "Real"] + (+0 "java.lang.Double" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Frac + (+12 ["lux" "Frac"] + (+0 "#Frac" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Char + (+12 ["lux" "Char"] + (+0 "java.lang.Character" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Text + (+12 ["lux" "Text"] + (+0 "java.lang.String" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Void + (+12 ["lux" "Void"] + (+1)) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Unit + (+12 ["lux" "Unit"] + (+2)) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Ident + (+12 ["lux" "Ident"] + (+4 Text Text)) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+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)))] + (+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))] + #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 +## (#BoolM Bool) +## (#NatM Nat) +## (#IntM Int) +## (#FracM Frac) +## (#RealM Real) +## (#CharM Char) +## (#TextM Text) +## (#IdentM Ident) +## (#ListM (List Ann-Value)) +## (#DictM (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 ## #BoolM + Bool + (#SumT ## #NatM + Nat + (#SumT ## #IntM + Int + (#SumT ## #FracM + Frac + (#SumT ## #RealM + Real + (#SumT ## #CharM + Char + (#SumT ## #TextM + Text + (#SumT ## #IdentM + Ident + (#SumT ## #ListM + (#AppT List Ann-Value) + ## #DictM + (#AppT List (#ProdT Text Ann-Value))))))))))) + ) + Void) + )) + (#Cons [["lux" "type?"] (+0 true)] + (#Cons [["lux" "export?"] (+0 true)] + (#Cons [["lux" "tags"] (+8 (#Cons (+6 "BoolM") + (#Cons (+6 "NatM") + (#Cons (+6 "IntM") + (#Cons (+6 "FracM") + (#Cons (+6 "RealM") + (#Cons (+6 "CharM") + (#Cons (+6 "TextM") + (#Cons (+6 "IdentM") + (#Cons (+6 "ListM") + (#Cons (+6 "DictM") + #Nil)))))))))))] + (#Cons [["lux" "type-rec?"] (+0 true)] + #Nil))))) + +## (type: Anns +## (List [Ident Ann-Value])) +(_lux_def Anns + (#NamedT ["lux" "Anns"] + (#AppT List (#ProdT Ident Ann-Value))) + (#Cons [["lux" "type?"] (#BoolM true)] + (#Cons [["lux" "export?"] (#BoolM true)] + #Nil))) + +(_lux_def default-def-meta-exported + (_lux_: Anns + (#Cons [["lux" "type?"] (#BoolM true)] + (#Cons [["lux" "export?"] (#BoolM true)] + #Nil))) + #Nil) + +(_lux_def default-def-meta-unexported + (_lux_: Anns + (#Cons [["lux" "type?"] (#BoolM true)] + #Nil)) + #Nil) + +## (type: Def +## [Type Anns Unit]) +(_lux_def Def + (#NamedT ["lux" "Def"] + (#ProdT Type (#ProdT Anns Unit))) + 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"] (#ListM (#Cons (#TextM "counter") + (#Cons (#TextM "mappings") + #Nil)))] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "k") (#Cons (#TextM "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"] (#ListM (#Cons (#TextM "module") + (#Cons (#TextM "line") + (#Cons (#TextM "column") + #Nil))))] + (#Cons [["lux" "doc"] (#TextM "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"] (#ListM (#Cons (#TextM "meta") + (#Cons (#TextM "datum") + #Nil)))] + (#Cons [["lux" "doc"] (#TextM "The type of things that can have meta-data of arbitrary types.")] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "m") (#Cons (#TextM "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"] (#ListM (#Cons (#TextM "name") + (#Cons (#TextM "inner-closures") + (#Cons (#TextM "locals") + (#Cons (#TextM "closure") + #Nil)))))] + default-def-meta-exported)) + +## (type: (AST' w) +## (#BoolS Bool) +## (#NatS Nat) +## (#IntS Int) +## (#FracS Frac) +## (#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;FracS" + Frac + (#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"] (#ListM (#Cons (#TextM "BoolS") + (#Cons (#TextM "NatS") + (#Cons (#TextM "IntS") + (#Cons (#TextM "FracS") + (#Cons (#TextM "RealS") + (#Cons (#TextM "CharS") + (#Cons (#TextM "TextS") + (#Cons (#TextM "SymbolS") + (#Cons (#TextM "TagS") + (#Cons (#TextM "FormS") + (#Cons (#TextM "TupleS") + (#Cons (#TextM "RecordS") + #Nil)))))))))))))] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "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"] (#TextM "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"] (#ListM (#Cons (#TextM "Left") + (#Cons (#TextM "Right") + #Nil)))] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "l") (#Cons (#TextM "r") #;Nil)))] + 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"] (#ListM (#Cons (#TextM "module-hash") + (#Cons (#TextM "module-aliases") + (#Cons (#TextM "defs") + (#Cons (#TextM "imports") + (#Cons (#TextM "tags") + (#Cons (#TextM "types") + (#Cons (#TextM "module-anns") + #Nil))))))))] + default-def-meta-exported)) + +## (type: CompilerMode +## #Release +## #Debug +## #Eval +## #REPL) +(_lux_def CompilerMode + (#NamedT ["lux" "CompilerMode"] + (#SumT ## "lux;Release" + #UnitT + (#SumT ## "lux;Debug" + #UnitT + (#SumT ## "lux;Eval" + #UnitT + ## "lux;REPL" + #UnitT)))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "Release") + (#Cons (#TextM "Debug") + (#Cons (#TextM "Eval") + (#Cons (#TextM "REPL") + #Nil)))))] + default-def-meta-exported)) + +## (type: CompilerInfo +## {#compiler-name Text +## #compiler-version Text +## #compiler-mode CompilerMode}) +(_lux_def CompilerInfo + (#NamedT ["lux" "CompilerInfo"] + (#ProdT ## "lux;compiler-name" + Text + (#ProdT ## "lux;compiler-version" + Text + ## "lux;compiler-mode" + CompilerMode))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "compiler-name") + (#Cons (#TextM "compiler-version") + (#Cons (#TextM "compiler-mode") + #Nil))))] + default-def-meta-exported)) + +## (type: Compiler +## {#info CompilerInfo +## #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" + CompilerInfo + (#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"] (#ListM (#Cons (#TextM "info") + (#Cons (#TextM "source") + (#Cons (#TextM "cursor") + (#Cons (#TextM "modules") + (#Cons (#TextM "scopes") + (#Cons (#TextM "type-vars") + (#Cons (#TextM "expected") + (#Cons (#TextM "seed") + (#Cons (#TextM "scope-type-vars") + (#Cons (#TextM "host") + #Nil)))))))))))] + (#Cons [["lux" "doc"] (#TextM "Represents the state of the Lux compiler during a run. + It's 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"] (#TextM "Computations that can have access to the state of the compiler. + Those computations may also fail, or modify the state of the compiler.")] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "a") #;Nil))] + default-def-meta-exported))) + +## (type: Macro +## (-> (List AST) (Lux (List AST)))) +(_lux_def Macro + (#NamedT ["lux" "Macro"] + (#LambdaT ASTList (#AppT Lux ASTList))) + 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 frac$ + (_lux_: (#LambdaT Frac AST) + (_lux_lambda _ value (_meta (#FracS 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?"] (#BoolM 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" "BoolM"]) + (#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" "BoolM"]) + (#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" "BoolM"]) + (#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"] (#TextM "## Throws away any code given to it. + ## Great for commenting out code, while retaining syntax high-lightning 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"] (#TextM "## 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"] (#TextM "## 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"] (#TextM "## 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"] (#TextM "## 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"] (#TextM "## 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"] (#TextM "## 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"] (#TextM "## 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?"] (#BoolM 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"] (#TextM "## 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"] (#TextM "## 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"] (#ListM (list (#TextM "wrap") (#TextM "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<Maybe> + #Nil + ($' Monad Maybe) + {#wrap + (lambda' return [x] + (#Some x)) + + #bind + (lambda' [f ma] + (_lux_case ma + #None #None + (#Some a) (f a)))}) + +(def:''' Monad<Lux> + #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"] (#TextM "(if true + \"Oh, yeah!\" + \"Aw hell naw!\")")]) + (_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->Text 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 (#IdentM real-name)) + (#Right [state real-name]) + + _ + (#Right [state ident])) + + #None + (#Left ($_ Text/append "Unknown definition: " (Ident->Text ident)))) + + #None + (#Left ($_ Text/append "Unknown module: " module " @ " (Ident->Text 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<Lux> + [elems' (_lux_: ($' Lux ($' List AST)) + (mapM Monad<Lux> + (_lux_: (-> AST ($' Lux AST)) + (lambda' [elem] + (_lux_case elem + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] + (wrap spliced) + + _ + (do Monad<Lux> + [=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<Lux> + [=elems (mapM Monad<Lux> untemplate elems)] + (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))) + false + (do Monad<Lux> + [=elems (mapM Monad<Lux> 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))))) + + [_ [_ (#FracS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "FracS"]) (frac$ 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<Lux> + [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<Lux> + [output (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) + #let [[_ form'] output]] + (return [meta form'])) + + [_ [_ (#RecordS fields)]] + (do Monad<Lux> + [=fields (mapM Monad<Lux> + (_lux_: (-> (& AST AST) ($' Lux AST)) + (lambda' [kv] + (let' [[k v] kv] + (do Monad<Lux> + [=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"] (#TextM "## 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"] (#TextM "## 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<Lux> + [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"] (#TextM "## 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<Lux> + [=template (untemplate true "" template)] + (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) + + _ + (fail "Wrong syntax for `"))) + +(macro:' #export (' tokens) + (list [["lux" "doc"] (#TextM "## Quotation as a macro. + (' \"YOLO\")")]) + (_lux_case tokens + (#Cons template #Nil) + (do Monad<Lux> + [=template (untemplate false "" template)] + (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) + + _ + (fail "Wrong syntax for '"))) + +(macro:' #export (|> tokens) + (list [["lux" "doc"] (#TextM "## 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"] (#TextM "## 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"] (#TextM "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:''' (n= x y) + #Nil + (-> Nat Nat Bool) + (_lux_proc ["nat" "="] [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"] (#TextM "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary. + (do-template [<name> <diff>] + [(def: #export <name> + (-> Int Int) + (+ <diff>))] + + [inc 1] + [dec -1])")]) + (_lux_case tokens + (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) + (_lux_case [(mapM Monad<Maybe> get-name bindings) + (mapM Monad<Maybe> 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> <cmp> <type>] + [(def:''' (<name> x y) + #Nil + (-> <type> <type> Bool) + (_lux_proc ["jvm" <cmp>] [x y]))] + + ## [i= "leq" Int] + [i> "lgt" Int] + [i< "llt" Int] + ) + +(do-template [<name> <cmp> <eq> <type>] + [(def:''' (<name> x y) + #Nil + (-> <type> <type> Bool) + (if (<cmp> x y) + true + (<eq> x y)))] + + [i>= i> i= Int] + [i<= i< i= Int] + ) + +(do-template [<name> <op> <type>] + [(def:''' (<name> x y) + #Nil + (-> <type> <type> <type>) + (_lux_proc <op> [x y]))] + + [i+ ["jvm" "ladd"] Int] + [i- ["jvm" "lsub"] Int] + [i* ["jvm" "lmul"] Int] + [i/ ["jvm" "ldiv"] Int] + [i% ["jvm" "lrem"] Int] + + [n+ ["nat" "+"] Nat] + [n- ["nat" "-"] Nat] + [n* ["nat" "*"] Nat] + [n/ ["nat" "/"] Nat] + [n% ["nat" "%"] Nat] + ) + +(def:''' (multiple? div n) + #Nil + (-> Int Int Bool) + (i= 0 (i% n div))) + +(def:''' #export (not x) + #Nil + (-> 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<Maybe> + [$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 (#BoolM true)) + (_lux_case (get-meta ["lux" "export?"] def-meta) + (#Some (#BoolM 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 (#IdentM [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<Lux> + [module-name current-module-name] + (wrap [module-name name])) + + _ + (return ident))) + +(def:''' (find-macro ident) + #Nil + (-> Ident ($' Lux ($' Maybe Macro))) + (do Monad<Lux> + [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<Lux> + [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<Lux> + [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<Lux> + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (do Monad<Lux> + [expansion (macro args) + expansion' (mapM Monad<Lux> 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<Lux> + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (do Monad<Lux> + [expansion (macro args) + expansion' (mapM Monad<Lux> macro-expand-all expansion)] + (wrap (List/join expansion'))) + + #None + (do Monad<Lux> + [args' (mapM Monad<Lux> macro-expand-all args)] + (wrap (list (form$ (#Cons (symbol$ macro-name) (List/join args')))))))) + + [_ (#FormS members)] + (do Monad<Lux> + [members' (mapM Monad<Lux> macro-expand-all members)] + (wrap (list (form$ (List/join members'))))) + + [_ (#TupleS members)] + (do Monad<Lux> + [members' (mapM Monad<Lux> macro-expand-all members)] + (wrap (list (tuple$ (List/join members'))))) + + [_ (#RecordS pairs)] + (do Monad<Lux> + [pairs' (mapM Monad<Lux> + (lambda' [kv] + (let' [[key val] kv] + (do Monad<Lux> + [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"] (#TextM "## 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<Lux> + [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"] (#TextM "## 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"] (#TextM "## 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 [<name> <type> <value>] + [(def:''' (<name> xy) + #Nil + (All [a b] (-> (& a b) <type>)) + (let' [[x y] xy] <value>))] + + [first a x] + [second b y]) + +(def:''' (unfold-type-def type-asts) + #Nil + (-> ($' List AST) ($' Lux (& AST ($' Maybe ($' List Text))))) + (_lux_case type-asts + (#Cons [_ (#RecordS pairs)] #;Nil) + (do Monad<Lux> + [members (mapM Monad<Lux> + (: (-> [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<Lux> + [members (mapM Monad<Lux> + (: (-> 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"] (#TextM "## 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"] (#TextM "## 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:''' (Frac->Text x) + #Nil + (-> Frac Text) + (_lux_proc ["frac" "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) + + [_ (#FracS value)] + (Frac->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<Lux> + [??? (macro? macro-name)] + (if ??? + (do Monad<Lux> + [init-expansion (macro-expand-once (form$ (list& (symbol$ macro-name) (form$ macro-args) body branches')))] + (expander init-expansion)) + (do Monad<Lux> + [sub-expansion (expander branches')] + (wrap (list& (form$ (list& (symbol$ macro-name) macro-args)) + body + sub-expansion))))) + + (#;Cons pattern (#;Cons body branches')) + (do Monad<Lux> + [sub-expansion (expander branches')] + (wrap (list& pattern body sub-expansion))) + + #;Nil + (do Monad<Lux> [] (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"] (#TextM "## 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 ($_ * x y z)) + + _ + #None)")]) + (_lux_case tokens + (#Cons value branches) + (do Monad<Lux> + [expansion (expander branches)] + (wrap (list (` (;_lux_case (~ value) (~@ expansion)))))) + + _ + (fail "Wrong syntax for case"))) + +(macro:' #export (^ tokens) + (list [["lux" "doc"] (#TextM "## 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 ($_ * x y z)) + + _ + #None)")]) + (case tokens + (#Cons [_ (#FormS (#Cons pattern #Nil))] (#Cons body branches)) + (do Monad<Lux> + [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"] (#TextM "## 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"] (#TextM "## 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"] (#TextM "## 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" "BoolM"]) (bool$ value)))) + + [_ (#NatS value)] + (return (form$ (list (tag$ ["lux" "NatM"]) (nat$ value)))) + + [_ (#IntS value)] + (return (form$ (list (tag$ ["lux" "IntM"]) (int$ value)))) + + [_ (#FracS value)] + (return (form$ (list (tag$ ["lux" "FracM"]) (frac$ value)))) + + [_ (#RealS value)] + (return (form$ (list (tag$ ["lux" "RealM"]) (real$ value)))) + + [_ (#CharS value)] + (return (form$ (list (tag$ ["lux" "CharM"]) (char$ value)))) + + [_ (#TextS value)] + (return (form$ (list (tag$ ["lux" "TextM"]) (text$ value)))) + + [_ (#TagS [prefix name])] + (return (form$ (list (tag$ ["lux" "IdentM"]) (tuple$ (list (text$ prefix) (text$ name)))))) + + (^or [_ (#FormS _)] [_ (#SymbolS _)]) + (return ast) + + [_ (#TupleS xs)] + (do Monad<Lux> + [=xs (mapM Monad<Lux> process-def-meta-value xs)] + (wrap (form$ (list (tag$ ["lux" "ListM"]) (untemplate-list =xs))))) + + [_ (#RecordS kvs)] + (do Monad<Lux> + [=xs (mapM Monad<Lux> + (: (-> [AST AST] (Lux AST)) + (lambda [[k v]] + (case k + [_ (#TextS =k)] + (do Monad<Lux> + [=v (process-def-meta-value v)] + (wrap (tuple$ (list (text$ =k) =v)))) + + _ + (fail (Text/append "Wrong syntax for DictM key: " (ast-to-text k)))))) + kvs)] + (wrap (form$ (list (tag$ ["lux" "DictM"]) (untemplate-list =xs))))) + )) + +(def:' (process-def-meta ast) + (-> AST (Lux AST)) + (case ast + [_ (#RecordS kvs)] + (do Monad<Lux> + [=kvs (mapM Monad<Lux> + (: (-> [AST AST] (Lux AST)) + (lambda [[k v]] + (case k + [_ (#TagS [pk nk])] + (do Monad<Lux> + [=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"] + (#;ListM (list (~@ (map (lambda [arg] + (` (#;TextM (~ (text$ (ast-to-text arg)))))) + args))))] + (~ meta))))) + +(def:' (with-type-args args) + (-> (List AST) AST) + (` {#;type-args (#;ListM (list (~@ (map (lambda [arg] + (` (#;TextM (~ (text$ (ast-to-text arg)))))) + args))))})) + +(def:' Export-Level + Type + ($' Either + Unit ## Exported + Unit ## Hidden + )) + +(def:' (export-level^ tokens) + (-> (List AST) [(Maybe Export-Level) (List AST)]) + (case tokens + (#Cons [_ (#TagS [_ "export"])] tokens') + [(#;Some (#;Left [])) tokens'] + + (#Cons [_ (#TagS [_ "hidden"])] tokens') + [(#;Some (#;Right [])) tokens'] + + _ + [#;None tokens])) + +(def:' (export-level ?el) + (-> (Maybe Export-Level) (List AST)) + (case ?el + #;None + (list) + + (#;Some (#;Left [])) + (list (' #export)) + + (#;Some (#;Right [])) + (list (' #hidden)))) + +(macro:' #export (def: tokens) + (list [["lux" "doc"] (#TextM "## 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))] 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<Lux> + [=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"] (#TextM "(macro: #export (ident-for tokens) + (case tokens + (^template [<tag>] + (^ (list [_ (<tag> [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<Lux> + [name+ (normalize name) + sigs' (mapM Monad<Lux> macro-expand sigs) + members (: (Lux (List [Text AST])) + (mapM Monad<Lux> + (: (-> 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: #export (log! message) + (-> Text Unit) + (_lux_proc ["jvm" "invokevirtual:java.io.PrintStream:println:java.lang.String"] + [(_lux_proc ["jvm" "getstatic:java.lang.System:out"] []) message])) + +(def: (split-text splitter input) + (-> Text Text (List Text)) + (let [idx (index-of splitter input)] + (if (i< idx 0) + (#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< idx 0) + #Nil + (split-module-contexts (substring2 0 idx module)))))) + +(def: (split-module module) + (-> Text (List Text)) + (let [idx (index-of "/" module)] + (if (i< idx 0) + (list module) + (list& (substring2 0 idx module) (split-module (substring1 (i+ 1 idx) module)))))) + +(def: (at idx xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons x xs') + (if (i= idx 0) + (#Some x) + (at (i- idx 1) 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 (at (_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<Maybe> + [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + (#NamedT name type) + (apply-type type param) + + _ + #None)) + +(do-template [<name> <tag>] + [(def: (<name> type) + (-> Type (List Type)) + (case type + (<tag> left right) + (list& left (<name> right)) + + _ + (list type)))] + + [flatten-sum #;SumT] + [flatten-prod #;ProdT] + [flatten-lambda #;LambdaT] + [flatten-app #;AppT] + ) + +(def: (resolve-struct-type type) + (-> Type (Maybe (List Type))) + (case type + (#ProdT _) + (#Some (flatten-prod type)) + + (#AppT fun arg) + (do Monad<Maybe> + [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<Lux> + [module-name current-module-name] + (find-module module-name))) + +(def: (resolve-tag [module name]) + (-> Ident (Lux [Nat (List Ident) Bool Type])) + (do Monad<Lux> + [=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->Text [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<Lux> + [=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<Lux> + [tokens' (mapM Monad<Lux> 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<Lux> + (: (-> 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<Int> (Ord Int) + (def: eq Eq<Int>) + (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))] type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs)) + (#Some name args type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs) + + (^ (list& name type [meta-rec-cursor (#;RecordS meta-rec-parts)] 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<Maybe> + (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 [<name> <form> <message> <doc-msg>] + [(macro: #export (<name> tokens) + {#;doc <doc-msg>} + (case (reverse tokens) + (^ (list& last init)) + (return (list (fold (: (-> AST AST AST) + (lambda [pre post] (` <form>))) + last + init))) + + _ + (fail <message>)))] + + [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<Lux> + [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" "TextM"]) + (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<Lux> + (: (-> 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<Lux> + [defs' (extract-defs defs)] + (return [(#Only defs') tokens'])) + + (^ [_ (#FormS (list& [_ (#TagS ["" "exclude"])] defs))]) + (do Monad<Lux> + [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<Lux> + [defs' (extract-defs defs)] + (return [(#Only defs') tokens']))) + + (^ (list& [_ (#TagS "" "-")] tokens')) + (let [[defs tokens'] (split-with symbol? tokens')] + (do Monad<Lux> + [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<Lux> + [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 (at 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<Lux> + [imports' (mapM Monad<Lux> + (: (-> AST (Lux (List Importation))) + (lambda [token] + (case token + [_ (#SymbolS "" m-name)] + (do Monad<Lux> + [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<Lux> + [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<Lux> + [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<Lux> + [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<Lux> + [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 (#BoolM 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 Unit])) + (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->Text 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->Text name))) + + (#Some [def-type def-meta def-value]) + (#Right [state [def-type def-value]]))))) + +(def: (find-type ident) + (-> Ident (Lux Type)) + (do Monad<Lux> + [#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->Text ident))))) + (case (find-def-type ident state) + (#Some struct-type) + (#Right state struct-type) + + _ + (#Left ($_ Text/append "Unknown var: " (Ident->Text 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<Lux> + [output (resolve-type-tags type) + pattern (: (Lux AST) + (case output + (#Some [tags members]) + (do Monad<Lux> + [slots (mapM Monad<Lux> + (: (-> [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-sum type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")") + + (#ProdT _) + ($_ Text/append "[" (|> (flatten-prod 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<Lux> + [struct-type (find-type name) + output (resolve-type-tags struct-type)] + (case output + (#Some [tags members]) + (do Monad<Lux> + [slots (mapM Monad<Lux> (: (-> [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<Lux> + [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 (even? num) \"even\" + (odd? num) \"odd\" + ## else-branch + \"???\")"} + (if (i= 0 (i% (length tokens) 2)) + (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<Lux> + [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<Lux> + [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<Lux> + [output (resolve-type-tags type) + #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]] + (case output + (#Some [tags members]) + (do Monad<Lux> + [decls' (mapM Monad<Lux> + (: (-> [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<Int> \"i:\") + ## Will generate: + (def: i:+ (:: Number<Int> +)) + (def: i:- (:: Number<Int> -)) + (def: i:* (:: Number<Int> *)) + ..."} + (case tokens + (^ (list& [_ (#SymbolS struct-name)] tokens')) + (do Monad<Lux> + [@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<Lux> + [decls' (mapM Monad<Lux> (: (-> [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 [<something>] + (fold Text/append \"\" + (interpose \" \" + (map ->Text <something>))))"} + (do Monad<Lux> + [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<Lux> + [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 #;Some. + (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<Lux> + [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<Lux> + (: (-> 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<Lux> + [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<Lux> + (: (-> 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<Lux> + [*defs (exported-defs module-name) + _ (test-referrals module-name *defs +defs)] + (wrap +defs)) + + (#Exclude -defs) + (do Monad<Lux> + [*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"] (#IdentM [(~ (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: #export (refer tokens) + (case tokens + (^ (list& [_ (#TextS module-name)] options)) + (do Monad<Lux> + [=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 "## Examples + (;module: {#;doc \"Some documentation...\"} + lux + (lux (control (monad #as M #refer #all)) + (data (text #open (\"Text/\" Monoid<Text>)) + (struct (list #open (\"List/\" Monad<List>))) + maybe + (ident #open (\"Ident/\" Codec<Text,Ident>))) + meta + (macro ast)) + (.. (type #open (\"\" Eq<Type>)))) + + (;module: {#;doc \"Some documentation...\"} + lux + (lux (control [\"M\" monad #*]) + (data [text \"Text/\" Monoid<Text>] + (struct [list \"List/\" Monad<List>]) + maybe + [ident \"Ident/\" Codec<Text,Ident>]) + meta + (macro ast)) + (.. [type \"\" Eq<Type>]))"} + (do Monad<Lux> + [#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<Text,Int> encode) + + ## Also allows using that value as a function. + (:: Codec<Text,Int> 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<Lux> + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags exported? type] output]] + (case (resolve-struct-type type) + (#Some members) + (do Monad<Lux> + [pattern' (mapM Monad<Lux> + (: (-> [Ident [Nat Type]] (Lux [Ident Nat AST])) + (lambda [[r-slot-name [r-idx r-type]]] + (do Monad<Lux> + [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<Lux> + [bindings (mapM Monad<Lux> + (: (-> 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<Lux> + [g!record (gensym "record")] + (wrap (list (` (lambda [(~ g!record)] (;;set@ (~ selector) (~ value) (~ g!record))))))) + + (^ (list selector)) + (do Monad<Lux> + [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 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<Lux> + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags exported? type] output]] + (case (resolve-struct-type type) + (#Some members) + (do Monad<Lux> + [pattern' (mapM Monad<Lux> + (: (-> [Ident [Nat Type]] (Lux [Ident Nat AST])) + (lambda [[r-slot-name [r-idx r-type]]] + (do Monad<Lux> + [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<Lux> + [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<Lux> + [g!record (gensym "record")] + (wrap (list (` (lambda [(~ g!record)] (;;update@ (~ selector) (~ fun) (~ g!record))))))) + + (^ (list selector)) + (do Monad<Lux> + [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 [<tag>] + (<tag> left right) + (<tag> (beta-reduce env left) (beta-reduce env right))) + ([#;SumT] [#;ProdT]) + + (^template [<tag>] + (<tag> left right) + (<tag> (beta-reduce env left) (beta-reduce env right))) + ([#;LambdaT] + [#;AppT]) + + (^template [<tag>] + (<tag> old-env def) + (case old-env + #;Nil + (<tag> env def) + + _ + type)) + ([#;UnivQ] + [#;ExQ]) + + (#;BoundT idx) + (default type (list;at idx env)) + + (#;NamedT name type) + (beta-reduce env type) + + _ + type + ))"} + (case tokens + (^ (list& [_ (#FormS (list& [_ (#TupleS bindings)] templates))] + [_ (#FormS data)] + branches)) + (case (: (Maybe (List AST)) + (do Monad<Maybe> + [bindings' (mapM Monad<Maybe> get-name bindings) + data' (mapM Monad<Maybe> 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 [<name> <from> <to> <converter>] + [(def: #export (<name> n) + (-> <from> <to>) + (_lux_proc ["jvm" <converter>] [n]))] + + [real-to-int Real Int "d2l"] + [int-to-real Int Real "l2d"] + ) + +(do-template [<type> <category> <=-name> <=> <lt-name> <lte-name> <lt> <gt-name> <gte-name> + <eq-doc> <<-doc> <<=-doc> <>-doc> <>=-doc>] + [(def: #export (<=-name> test subject) + {#;doc <eq-doc>} + (-> <type> <type> Bool) + (_lux_proc [<category> <=>] [subject test])) + + (def: #export (<lt-name> test subject) + {#;doc <<-doc>} + (-> <type> <type> Bool) + (_lux_proc [<category> <lt>] [subject test])) + + (def: #export (<lte-name> test subject) + {#;doc <<=-doc>} + (-> <type> <type> Bool) + (or (_lux_proc [<category> <lt>] [subject test]) + (_lux_proc [<category> <=>] [subject test]))) + + (def: #export (<gt-name> test subject) + {#;doc <>-doc>} + (-> <type> <type> Bool) + (_lux_proc [<category> <lt>] [test subject])) + + (def: #export (<gte-name> test subject) + {#;doc <>=-doc>} + (-> <type> <type> Bool) + (or (_lux_proc [<category> <lt>] [test subject]) + (_lux_proc [<category> <=>] [subject test])))] + + [ Nat "nat" =+ "=" <+ <=+ "<" >+ >=+ + "Natural equality." "Natural less-than." "Natural less-than-equal." "Natural greater-than." "Natural greater-than-equal."] + + [ Int "jvm" = "leq" < <= "llt" > >= + "Integer equality." "Integer less-than." "Integer less-than-equal." "Integer greater-than." "Integer greater-than-equal."] + + [Frac "frac" =.. "=" <.. <=.. "<" >.. >=.. + "Fractional equality." "Fractional less-than." "Fractional less-than-equal." "Fractional greater-than." "Fractional greater-than-equal."] + + [Real "jvm" =. "deq" <. <=. "dlt" >. >=. + "Real equality." "Real less-than." "Real less-than-equal." "Real greater-than." "Real greater-than-equal."] + ) + +(do-template [<type> <name> <op> <doc>] + [(def: #export (<name> param subject) + {#;doc <doc>} + (-> <type> <type> <type>) + (_lux_proc <op> [subject param]))] + + [ Nat ++ ["nat" "+"] "Nat(ural) addition."] + [ Nat -+ ["nat" "-"] "Nat(ural) substraction."] + [ Nat *+ ["nat" "*"] "Nat(ural) multiplication."] + [ Nat /+ ["nat" "/"] "Nat(ural) division."] + [ Nat %+ ["nat" "%"] "Nat(ural) remainder."] + + [ Int + ["jvm" "ladd"] "Int(eger) addition."] + [ Int - ["jvm" "lsub"] "Int(eger) substraction."] + [ Int * ["jvm" "lmul"] "Int(eger) multiplication."] + [ Int / ["jvm" "ldiv"] "Int(eger) division."] + [ Int % ["jvm" "lrem"] "Int(eger) remainder."] + + [Frac +.. ["frac" "+"] "Frac(tional) addition."] + [Frac -.. ["frac" "-"] "Frac(tional) substraction."] + [Frac *.. ["frac" "*"] "Frac(tional) multiplication."] + [Frac /.. ["frac" "/"] "Frac(tional) division."] + [Frac %.. ["frac" "%"] "Frac(tional) remainder."] + + [Real +. ["jvm" "dadd"] "Real addition."] + [Real -. ["jvm" "dsub"] "Real substraction."] + [Real *. ["jvm" "dmul"] "Real multiplication."] + [Real /. ["jvm" "ddiv"] "Real division."] + [Real %. ["jvm" "drem"] "Real remainder."] + ) + +(do-template [<name> <type> <test> <doc>] + [(def: #export (<name> left right) + {#;doc <doc>} + (-> <type> <type> <type>) + (if (<test> right left) + left + right))] + + [min+ Nat <+ "Nat(ural) minimum."] + [max+ Nat >+ "Nat(ural) maximum."] + + [min Int < "Int(eger) minimum."] + [max Int > "Int(eger) maximum."] + + [min.. Frac <.. "Frac(tional) minimum."] + [max.. Frac >.. "Frac(tional) maximum."] + + [min. Real <. "Real minimum."] + [max. Real >. "Real minimum."] + ) + +(def: (find-baseline-column ast) + (-> AST Int) + (case ast + (^template [<tag>] + [[_ _ column] (<tag> _)] + column) + ([#BoolS] + [#NatS] + [#IntS] + [#FracS] + [#RealS] + [#CharS] + [#TextS] + [#SymbolS] + [#TagS]) + + (^template [<tag>] + [[_ _ column] (<tag> parts)] + (fold min column (map find-baseline-column parts))) + ([#FormS] + [#TupleS]) + + [[_ _ column] (#RecordS pairs)] + (fold 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 [<name> <diff>] + [(def: #export <name> + (-> Int Int) + (i+ <diff>))] + + [inc 1] + [dec -1]) + +(def: tag->Text + (-> Ident Text) + (. (Text/append "#") Ident->Text)) + +(def: (repeat n x) + (All [a] (-> Int a (List a))) + (if (i> n 0) + (#;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- new-column old-column) " ")) + (let [extra-lines (Text/join (repeat (i- new-line old-line) "\n")) + space-padding (Text/join (repeat (i- new-column baseline) " "))] + (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 (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 [<tag> <show>] + [new-cursor (<tag> value)] + (let [as-text (<show> 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] + [#FracS Frac->Text] + [#RealS ->Text] + [#CharS Char/encode] + [#TextS Text/encode] + [#SymbolS Ident->Text] + [#TagS tag->Text]) + + (^template [<tag> <open> <close> <prep>] + [group-cursor (<tag> 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) ""] + (<prep> parts))] + [(delim-update-cursor group-cursor') + ($_ Text/append (cursor-padding baseline prev-cursor group-cursor) + <open> + parts-text + <close>)])) + ([#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 (inc count) (f x)) + x)))"} + (return (list (` (#;TextM (~ (|> 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->ast type) + (-> Type AST) + (case type + (#HostT name params) + (` (#HostT (~ (text$ name)) (~ (untemplate-list (map type->ast params))))) + + #VoidT + (` #VoidT) + + #UnitT + (` #UnitT) + + (^template [<tag>] + (<tag> left right) + (` (<tag> (~ (type->ast left)) (~ (type->ast right))))) + ([#SumT] [#ProdT]) + + (#LambdaT in out) + (` (#LambdaT (~ (type->ast in)) (~ (type->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->ast env))] + (` (#UnivQ (~ env') (~ (type->ast type))))) + + (#ExQ env type) + (let [env' (untemplate-list (map type->ast env))] + (` (#ExQ (~ env') (~ (type->ast type))))) + + (#AppT fun arg) + (` (#AppT (~ (type->ast fun)) (~ (type->ast arg)))) + + (#NamedT [module name] type) + (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->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 (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<Lux> + [inits' (: (Lux (List Ident)) + (case (mapM Monad<Maybe> get-ident inits) + (#Some inits') (return inits') + #None (fail "Wrong syntax for loop"))) + init-types (mapM Monad<Lux> find-type inits') + expected get-expected-type] + (return (list (` ((;_lux_: (-> (~@ (map type->ast init-types)) + (~ (type->ast expected))) + (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] + (~ body))) + (~@ inits)))))) + (do Monad<Lux> + [aliases (mapM Monad<Lux> + (: (-> 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<Lux> + [slots (: (Lux [Ident (List Ident)]) + (case (: (Maybe [Ident (List Ident)]) + (do Monad<Maybe> + [hslot (get-tag hslot') + tslots (mapM Monad<Maybe> 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<Lux> 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 _)] [_ (#FracS _)] [_ (#RealS _)] [_ (#CharS _)] [_ (#TextS _)] [_ (#TagS _)]) + (#Some (list target)) + + [_ (#SymbolS [prefix name])] + (if (and (Text/= "" prefix) + (Text/= label name)) + (#Some tokens) + (#Some (list target))) + + (^template [<tag> <ctor>] + [_ (<tag> elems)] + (do Monad<Maybe> + [placements (mapM Monad<Maybe> (place-tokens label tokens) elems)] + (wrap (list (<ctor> (List/join placements)))))) + ([#TupleS tuple$] + [#FormS form$]) + + [_ (#RecordS pairs)] + (do Monad<Maybe> + [=pairs (mapM Monad<Maybe> + (: (-> [AST AST] (Maybe [AST AST])) + (lambda [[slot value]] + (do Monad<Maybe> + [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% [<tests> (do-template [<expr> <text> <pattern>] + [(compare <pattern> <expr>) + (compare <text> (:: AST/Show show <expr>)) + (compare true (:: Eq<AST> = <expr> <expr>))] + + [(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 <tests>))))} + (case tokens + (^ (list& [_ (#TupleS bindings)] bodies)) + (case bindings + (^ (list& [_ (#SymbolS ["" var-name])] macro-expr bindings')) + (do Monad<Lux> + [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 [<name>] + (#NamedT ["lux" <name>] _) + type) + (["Bool"] + ["Nat"] + ["Int"] + ["Frac"] + ["Real"] + ["Char"] + ["Text"]) + + (#NamedT _ type') + type' + + _ + type)) + +(def: (anti-quote-def name) + (-> Ident (Lux AST)) + (do Monad<Lux> + [type+value (find-def-value name) + #let [[type value] type+value]] + (case (flatten-alias type) + (^template [<name> <type> <wrapper>] + (#NamedT ["lux" <name>] _) + (wrap (<wrapper> (:! <type> value)))) + (["Bool" Bool bool$] + ["Nat" Nat nat$] + ["Int" Int int$] + ["Frac" Frac frac$] + ["Real" Real real$] + ["Char" Char char$] + ["Text" Text text$]) + + _ + (fail (Text/append "Can't anti-quote type: " (Ident->Text name)))))) + +(def: (anti-quote token) + (-> AST (Lux AST)) + (case token + [_ (#SymbolS [def-prefix def-name])] + (if (Text/= "" def-prefix) + (:: Monad<Lux> return token) + (anti-quote-def [def-prefix def-name])) + + (^template [<tag>] + [meta (<tag> parts)] + (do Monad<Lux> + [=parts (mapM Monad<Lux> anti-quote parts)] + (wrap [meta (<tag> =parts)]))) + ([#FormS] + [#TupleS]) + + [meta (#RecordS pairs)] + (do Monad<Lux> + [=pairs (mapM Monad<Lux> + (: (-> [AST AST] (Lux [AST AST])) + (lambda [[slot value]] + (do Monad<Lux> + [=value (anti-quote value)] + (wrap [slot =value])))) + pairs)] + (wrap [meta (#RecordS =pairs)])) + + _ + (:: Monad<Lux> 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<Lux> + [module-name current-module-name + pattern+ (macro-expand-all pattern)] + (case pattern+ + (^ (list pattern')) + (do Monad<Lux> + [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 + (^ [_ (#;RecordS (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<Lux> + [extras' (mapM Monad<Lux> 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<Lux> + [mlc (multi-level-case^ levels) + expected get-expected-type + g!temp (gensym "temp")] + (let [output (list g!temp + (` (;_lux_case (;_lux_: (#;AppT Maybe (~ (type->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 [<tag>] + (^ (list [_ (<tag> [prefix name])])) + (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))) + ([#;SymbolS] [#;TagS]) + + _ + (fail "Wrong syntax for ident-for"))) + +(do-template [<type> <even> <odd> <%> <=> <0> <2>] + [(def: #export (<even> n) + (-> <type> Bool) + (<=> <0> (<%> n <2>))) + + (def: #export (<odd> n) + (-> <type> Bool) + (not (<even> n)))] + + [Nat even?+ odd?+ n% n= +0 +2] + [Int even? 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] (-> Int (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons x xs') + (if (i= 0 idx) + (#;Some x) + (list-at (dec idx) xs')))) + +(macro: #export ($ tokens) + (case tokens + (^ (list [_ (#IntS idx)])) + (do Monad<Lux> + [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 (== left right) + {#;doc (doc "Tests whether the 2 values are identical (not just \"equal\")." + "This one should succeed:" + (let [value 5] + (== 5 5)) + + "This one should fail:" + (== 5 (+ 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 [a/Hash _])) + (List/fold (lambda [elem acc] (+ (:: a/Hash hash elem) acc)) + 0 + (->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) + (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<Lux> + [type get-expected-type] + (wrap (list (` (;_lux_:! (~ (type->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<Lux> + [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." + (def: (square x) + (-> Int Int) + (undefined)))} + (case tokens + #;Nil + (return (list (` (error! (with-cursor "Undefined behavior."))))) + + _ + (fail "Wrong syntax for undefined"))) + +(macro: #export (@pre tokens) + (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) + (case tokens + (^ (list test pattern expr)) + (do Monad<Lux> + [g!output (gensym "") + exp-type get-expected-type] + (wrap (list (` (let [(~ g!output) (: (~ (type->ast exp-type)) (~ expr)) + (~ pattern) (~ g!output)] + (if (~ test) + (~ g!output) + (error! (with-cursor (~ (text$ (Text/append "Post-condition failed: " (ast-to-text test)))))))))))) + + _ + (fail "Wrong syntax for @post"))) + +(do-template [<name> <op> <from> <to>] + [(def: #export (<name> input) + (-> <from> <to>) + (_lux_proc <op> [input]))] + + [int-to-nat ["int" "to-nat"] Int Nat] + [nat-to-int ["nat" "to-int"] Nat Int] + + [real-to-frac ["real" "to-frac"] Real Frac] + [frac-to-real ["frac" "to-real"] Frac Real] + ) + +(do-template [<name> <op>] + [(def: #export <name> + (-> Nat Nat) + (<op> +1))] + + [inc+ ++] + [dec+ -+]) |