aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/lux.lux')
-rw-r--r--stdlib/source/lux.lux5541
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+ -+])
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-05 03:26:33 +0000