aboutsummaryrefslogtreecommitdiff
path: root/input
diff options
context:
space:
mode:
authorEduardo Julian2015-06-20 20:19:02 -0400
committerEduardo Julian2015-06-20 20:19:02 -0400
commit5e9e876131901204dd34ce1548a4df3cb6cba95f (patch)
tree82bb0f7f20fe13f91f15656ed61f28e585b19ced /input
parent082ef348efef7c4f1941c48f94b58e22fea724a4 (diff)
- The directory for source-code is now named "input".
- Implemented module-caching to avoid the waiting too much during program compilation.
Diffstat (limited to 'input')
-rw-r--r--input/lux.lux2173
-rw-r--r--input/program.lux15
2 files changed, 2188 insertions, 0 deletions
diff --git a/input/lux.lux b/input/lux.lux
new file mode 100644
index 000000000..6c9a50f9d
--- /dev/null
+++ b/input/lux.lux
@@ -0,0 +1,2173 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## The use and distribution terms for this software are covered by the
+## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+## which can be found in the file epl-v10.html at the root of this distribution.
+## By using this software in any fashion, you are agreeing to be bound by
+## the terms of this license.
+## You must not remove this notice, or any other, from this software.
+
+## First things first, must define functions
+(_jvm_interface "Function" []
+ (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"]))
+
+## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"]
+## [(foo "java.lang.Object" ["public" "static"])]
+## (<init> [] "void"
+## ["public"]
+## (_jvm_invokespecial java.lang.Object <init> [] this []))
+## (apply [(arg "java.lang.Object")] "java.lang.Object"
+## ["public"]
+## "YOLO"))
+
+## Basic types
+(_lux_def Bool (#DataT "java.lang.Boolean"))
+(_lux_export Bool)
+
+(_lux_def Int (#DataT "java.lang.Long"))
+(_lux_export Int)
+
+(_lux_def Real (#DataT "java.lang.Double"))
+(_lux_export Real)
+
+(_lux_def Char (#DataT "java.lang.Character"))
+(_lux_export Char)
+
+(_lux_def Text (#DataT "java.lang.String"))
+(_lux_export Text)
+
+(_lux_def Void (#VariantT #Nil))
+(_lux_export Void)
+
+(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])])))
+(_lux_export Ident)
+
+## (deftype (List a)
+## (| #Nil
+## (#Cons (, a (List a)))))
+(_lux_def List
+ (#AllT [(#Some #Nil) "lux;List" "a"
+ (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)]
+ (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a")
+ (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")])
+ #Nil])]))]
+ #Nil])]))]))
+(_lux_export List)
+
+## (deftype (Maybe a)
+## (| #None
+## (#Some a)))
+(_lux_def Maybe
+ (#AllT [(#Some #Nil) "lux;Maybe" "a"
+ (#VariantT (#Cons [["lux;None" (#TupleT #Nil)]
+ (#Cons [["lux;Some" (#BoundT "a")]
+ #Nil])]))]))
+(_lux_export Maybe)
+
+## (deftype #rec Type
+## (| (#DataT Text)
+## (#TupleT (List Type))
+## (#VariantT (List (, Text Type)))
+## (#RecordT (List (, Text Type)))
+## (#LambdaT (, Type Type))
+## (#BoundT Text)
+## (#VarT Int)
+## (#AllT (, (Maybe (List (, Text Type))) Text Text Type))
+## (#AppT (, Type Type))))
+(_lux_def Type
+ (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")])
+ Type
+ (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))])
+ TypeEnv
+ (#AppT [(#AllT [(#Some #Nil) "Type" "_"
+ (#VariantT (#Cons [["lux;DataT" Text]
+ (#Cons [["lux;TupleT" (#AppT [List Type])]
+ (#Cons [["lux;VariantT" TypeEnv]
+ (#Cons [["lux;RecordT" TypeEnv]
+ (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))]
+ (#Cons [["lux;BoundT" Text]
+ (#Cons [["lux;VarT" Int]
+ (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))]
+ (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))]
+ (#Cons [["lux;ExT" Int]
+ #Nil])])])])])])])])])]))])
+ Void]))))
+(_lux_export Type)
+
+## (deftype (Bindings k v)
+## (& #counter Int
+## #mappings (List (, k v))))
+(_lux_def Bindings
+ (#AllT [(#Some #Nil) "lux;Bindings" "k"
+ (#AllT [#None "" "v"
+ (#RecordT (#Cons [["lux;counter" Int]
+ (#Cons [["lux;mappings" (#AppT [List
+ (#TupleT (#Cons [(#BoundT "k")
+ (#Cons [(#BoundT "v")
+ #Nil])]))])]
+ #Nil])]))])]))
+
+## (deftype (Env k v)
+## (& #name Text
+## #inner-closures Int
+## #locals (Bindings k v)
+## #closure (Bindings k v)))
+(_lux_def Env
+ (#AllT [(#Some #Nil) "lux;Env" "k"
+ (#AllT [#None "" "v"
+ (#RecordT (#Cons [["lux;name" Text]
+ (#Cons [["lux;inner-closures" Int]
+ (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")])
+ (#BoundT "v")])]
+ (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")])
+ (#BoundT "v")])]
+ #Nil])])])]))])]))
+
+## (deftype Cursor
+## (, Text Int Int))
+(_lux_def Cursor
+ (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])])))
+
+## (deftype (Meta m v)
+## (| (#Meta (, m v))))
+(_lux_def Meta
+ (#AllT [(#Some #Nil) "lux;Meta" "m"
+ (#AllT [#None "" "v"
+ (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m")
+ (#Cons [(#BoundT "v")
+ #Nil])]))]
+ #Nil]))])]))
+(_lux_export Meta)
+
+## (deftype (Syntax' w)
+## (| (#BoolS Bool)
+## (#IntS Int)
+## (#RealS Real)
+## (#CharS Char)
+## (#TextS Text)
+## (#SymbolS (, Text Text))
+## (#TagS (, Text Text))
+## (#FormS (List (w (Syntax' w))))
+## (#TupleS (List (w (Syntax' w))))
+## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w)))))))
+(_lux_def Syntax'
+ (_lux_case (#AppT [(#BoundT "w")
+ (#AppT [(#BoundT "lux;Syntax'")
+ (#BoundT "w")])])
+ Syntax
+ (_lux_case (#AppT [List Syntax])
+ SyntaxList
+ (#AllT [(#Some #Nil) "lux;Syntax'" "w"
+ (#VariantT (#Cons [["lux;BoolS" Bool]
+ (#Cons [["lux;IntS" Int]
+ (#Cons [["lux;RealS" Real]
+ (#Cons [["lux;CharS" Char]
+ (#Cons [["lux;TextS" Text]
+ (#Cons [["lux;SymbolS" Ident]
+ (#Cons [["lux;TagS" Ident]
+ (#Cons [["lux;FormS" SyntaxList]
+ (#Cons [["lux;TupleS" SyntaxList]
+ (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])]
+ #Nil])
+ ])])])])])])])])])
+ )]))))
+(_lux_export Syntax')
+
+## (deftype Syntax
+## (Meta Cursor (Syntax' (Meta Cursor))))
+(_lux_def Syntax
+ (_lux_case (#AppT [Meta Cursor])
+ w
+ (#AppT [w (#AppT [Syntax' w])])))
+(_lux_export Syntax)
+
+(_lux_def SyntaxList (#AppT [List Syntax]))
+
+## (deftype (Either l r)
+## (| (#Left l)
+## (#Right r)))
+(_lux_def Either
+ (#AllT [(#Some #Nil) "lux;Either" "l"
+ (#AllT [#None "" "r"
+ (#VariantT (#Cons [["lux;Left" (#BoundT "l")]
+ (#Cons [["lux;Right" (#BoundT "r")]
+ #Nil])]))])]))
+(_lux_export Either)
+
+## (deftype (StateE s a)
+## (-> s (Either Text (, s a))))
+(_lux_def StateE
+ (#AllT [(#Some #Nil) "lux;StateE" "s"
+ (#AllT [#None "" "a"
+ (#LambdaT [(#BoundT "s")
+ (#AppT [(#AppT [Either Text])
+ (#TupleT (#Cons [(#BoundT "s")
+ (#Cons [(#BoundT "a")
+ #Nil])]))])])])]))
+
+## (deftype Reader
+## (List (Meta Cursor Text)))
+(_lux_def Reader
+ (#AppT [List
+ (#AppT [(#AppT [Meta Cursor])
+ Text])]))
+(_lux_export Reader)
+
+## (deftype HostState
+## (& #writer (^ org.objectweb.asm.ClassWriter)
+## #loader (^ java.net.URLClassLoader)
+## #classes (^ clojure.lang.Atom)))
+(_lux_def HostState
+ (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")]
+ (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")]
+ (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")]
+ #Nil])])])))
+
+## (deftype (DefData' m)
+## (| #TypeD
+## (#ValueD Type)
+## (#MacroD m)
+## (#AliasD Ident)))
+(_lux_def DefData'
+ (#AllT [(#Some #Nil) "lux;DefData'" ""
+ (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)]
+ (#Cons [["lux;ValueD" Type]
+ (#Cons [["lux;MacroD" (#BoundT "")]
+ (#Cons [["lux;AliasD" Ident]
+ #Nil])])])]))]))
+
+## (deftype LuxVar
+## (| (#Local Int)
+## (#Global Ident)))
+(_lux_def LuxVar
+ (#VariantT (#Cons [["lux;Local" Int]
+ (#Cons [["lux;Global" Ident]
+ #Nil])])))
+(_lux_export LuxVar)
+
+## (deftype (Module Compiler)
+## (& #module-aliases (List (, Text Text))
+## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))))
+## #imports (List Text)
+## ))
+(_lux_def Module
+ (#AllT [(#Some #Nil) "lux;Module" "Compiler"
+ (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])]
+ (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text
+ (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList
+ (#AppT [(#AppT [StateE (#BoundT "Compiler")])
+ SyntaxList])])])
+ #Nil])]))
+ #Nil])]))])]
+ (#Cons [["lux;imports" (#AppT [List Text])]
+ #Nil])])]))]))
+(_lux_export Module)
+
+## (deftype #rec Compiler
+## (& #source Reader
+## #modules (List (, Text (Module Compiler)))
+## #envs (List (Env Text (, LuxVar Type)))
+## #types (Bindings Int Type)
+## #host HostState
+## #seed Int
+## #seen-sources (List Text)
+## #eval? Bool))
+(_lux_def Compiler
+ (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" ""
+ (#RecordT (#Cons [["lux;source" Reader]
+ (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text
+ (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])])
+ #Nil])]))])]
+ (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text])
+ (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])]
+ (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])]
+ (#Cons [["lux;host" HostState]
+ (#Cons [["lux;seed" Int]
+ (#Cons [["lux;seen-sources" (#AppT [List Text])]
+ (#Cons [["lux;eval?" Bool]
+ #Nil])])])])])])])]))])
+ Void]))
+(_lux_export Compiler)
+
+## (deftype Macro
+## (-> (List Syntax) (StateE Compiler (List Syntax))))
+(_lux_def Macro
+ (#LambdaT [SyntaxList
+ (#AppT [(#AppT [StateE Compiler])
+ SyntaxList])]))
+(_lux_export Macro)
+
+## Base functions & macros
+## (def (_meta data)
+## (-> (Syntax' (Meta Cursor)) Syntax)
+## (#Meta [["" -1 -1] data]))
+(_lux_def _meta
+ (_lux_: (#LambdaT [(#AppT [Syntax'
+ (#AppT [Meta Cursor])])
+ Syntax])
+ (_lux_lambda _ data
+ (#Meta [["" -1 -1] data]))))
+
+## (def (return x)
+## (All [a]
+## (-> a Compiler
+## (Either Text (, Compiler a))))
+## ...)
+(_lux_def return
+ (_lux_: (#AllT [(#Some #Nil) "" "a"
+ (#LambdaT [(#BoundT "a")
+ (#LambdaT [Compiler
+ (#AppT [(#AppT [Either Text])
+ (#TupleT (#Cons [Compiler
+ (#Cons [(#BoundT "a")
+ #Nil])]))])])])])
+ (_lux_lambda _ val
+ (_lux_lambda _ state
+ (#Right [state val])))))
+
+## (def (fail msg)
+## (All [a]
+## (-> Text Compiler
+## (Either Text (, Compiler a))))
+## ...)
+(_lux_def fail
+ (_lux_: (#AllT [(#Some #Nil) "" "a"
+ (#LambdaT [Text
+ (#LambdaT [Compiler
+ (#AppT [(#AppT [Either Text])
+ (#TupleT (#Cons [Compiler
+ (#Cons [(#BoundT "a")
+ #Nil])]))])])])])
+ (_lux_lambda _ msg
+ (_lux_lambda _ state
+ (#Left msg)))))
+
+(_lux_def $text
+ (_lux_: (#LambdaT [Text Syntax])
+ (_lux_lambda _ text
+ (_meta (#TextS text)))))
+
+(_lux_def $symbol
+ (_lux_: (#LambdaT [Ident Syntax])
+ (_lux_lambda _ ident
+ (_meta (#SymbolS ident)))))
+
+(_lux_def $tag
+ (_lux_: (#LambdaT [Ident Syntax])
+ (_lux_lambda _ ident
+ (_meta (#TagS ident)))))
+
+(_lux_def $form
+ (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax])
+ (_lux_lambda _ tokens
+ (_meta (#FormS tokens)))))
+
+(_lux_def $tuple
+ (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax])
+ (_lux_lambda _ tokens
+ (_meta (#TupleS tokens)))))
+
+(_lux_def $record
+ (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax])
+ (_lux_lambda _ tokens
+ (_meta (#RecordS tokens)))))
+
+(_lux_def let'
+ (_lux_: Macro
+ (_lux_lambda _ tokens
+ (_lux_case tokens
+ (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])])
+ (return (_lux_: SyntaxList
+ (#Cons [($form (#Cons [($symbol ["" "_lux_case"])
+ (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])]))
+ #Nil])))
+
+ _
+ (fail "Wrong syntax for let'")))))
+(_lux_declare-macro let')
+
+(_lux_def lambda'
+ (_lux_: Macro
+ (_lux_lambda _ tokens
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])
+ (return (_lux_: SyntaxList
+ (#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 [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])])
+ (return (_lux_: SyntaxList
+ (#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")))))
+(_lux_declare-macro lambda')
+
+(_lux_def def'
+ (_lux_: Macro
+ (lambda' [tokens]
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TagS ["" "export"])])
+ (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
+ (#Cons [type (#Cons [body #Nil])])])])
+ (return (_lux_: SyntaxList
+ (#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])])])))
+ #Nil])])])))
+ (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])])))
+ #Nil])])))
+
+ (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
+ (return (_lux_: SyntaxList
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [body
+ #Nil])])])))
+ #Nil])])])))
+ (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])])))
+ #Nil])])))
+
+ (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
+ (#Cons [type (#Cons [body #Nil])])])
+ (return (_lux_: SyntaxList
+ (#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])])])))
+ #Nil])])])))
+ #Nil])))
+
+ (#Cons [name (#Cons [type (#Cons [body #Nil])])])
+ (return (_lux_: SyntaxList
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [body
+ #Nil])])])))
+ #Nil])])])))
+ #Nil])))
+
+ _
+ (fail "Wrong syntax for def")
+ ))))
+(_lux_declare-macro def')
+
+(def' #export (defmacro tokens)
+ Macro
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])
+ (return (_lux_: SyntaxList
+ (#Cons [($form (#Cons [($symbol ["lux" "def'"])
+ (#Cons [($form (#Cons [name args]))
+ (#Cons [($symbol ["lux" "Macro"])
+ (#Cons [body
+ #Nil])])
+ ])]))
+ (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])]))
+ #Nil])])))
+
+ (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])])
+ (return (_lux_: SyntaxList
+ (#Cons [($form (#Cons [($symbol ["lux" "def'"])
+ (#Cons [($tag ["" "export"])
+ (#Cons [($form (#Cons [name args]))
+ (#Cons [($symbol ["lux" "Macro"])
+ (#Cons [body
+ #Nil])])
+ ])])]))
+ (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])]))
+ #Nil])])))
+
+ _
+ (fail "Wrong syntax for defmacro")))
+(_lux_declare-macro defmacro)
+
+(defmacro #export (comment tokens)
+ (return (_lux_: SyntaxList #Nil)))
+
+(defmacro (->' tokens)
+ (_lux_case tokens
+ (#Cons [input (#Cons [output #Nil])])
+ (return (_lux_: SyntaxList
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"]))
+ (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])])))
+ #Nil])])))
+ #Nil])))
+
+ (#Cons [input (#Cons [output others])])
+ (return (_lux_: SyntaxList
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"]))
+ (#Cons [(_meta (#TupleS (#Cons [input
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"]))
+ (#Cons [output others])])))
+ #Nil])])))
+ #Nil])])))
+ #Nil])))
+
+ _
+ (fail "Wrong syntax for ->'")))
+
+(defmacro (All' tokens)
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TupleS #Nil)])
+ (#Cons [body #Nil])])
+ (return (_lux_: SyntaxList
+ (#Cons [body
+ #Nil])))
+
+ (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))])
+ (#Cons [body #Nil])])
+ (return (_lux_: SyntaxList
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"]))
+ (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"]))
+ (#Cons [(_meta (#TextS ""))
+ (#Cons [(_meta (#TextS arg-name))
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"]))
+ (#Cons [(_meta (#TupleS other-args))
+ (#Cons [body
+ #Nil])])])))
+ #Nil])])])])))
+ #Nil])])))
+ #Nil])))
+
+ _
+ (fail "Wrong syntax for All'")))
+
+(defmacro (B' tokens)
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#SymbolS ["" bound-name])])
+ #Nil])
+ (return (_lux_: SyntaxList
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"]))
+ (#Cons [(_meta (#TextS bound-name))
+ #Nil])])))
+ #Nil])))
+
+ _
+ (fail "Wrong syntax for B'")))
+
+(defmacro ($' tokens)
+ (_lux_case tokens
+ (#Cons [x #Nil])
+ (return tokens)
+
+ (#Cons [x (#Cons [y xs])])
+ (return (_lux_: SyntaxList
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"]))
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"]))
+ (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])])))
+ #Nil])])))
+ xs])])))
+ #Nil])))
+
+ _
+ (fail "Wrong syntax for $'")))
+
+(def' #export (foldL f init xs)
+ (All' [a b]
+ (->' (->' (B' a) (B' b) (B' a))
+ (B' a)
+ ($' List (B' b))
+ (B' a)))
+ (_lux_case xs
+ #Nil
+ init
+
+ (#Cons [x xs'])
+ (foldL f (f init x) xs')))
+
+(def' #export (foldR f init xs)
+ (All' [a b]
+ (->' (->' (B' b) (B' a) (B' a))
+ (B' a)
+ ($' List (B' b))
+ (B' a)))
+ (_lux_case xs
+ #Nil
+ init
+
+ (#Cons [x xs'])
+ (f x (foldR f init xs'))))
+
+(def' #export (reverse list)
+ (All' [a]
+ (->' ($' List (B' a)) ($' List (B' a))))
+ (foldL (_lux_: (All' [a]
+ (->' ($' List (B' a)) (B' a) ($' List (B' a))))
+ (lambda' [tail head]
+ (#Cons [head tail])))
+ #Nil
+ list))
+
+(defmacro #export (list xs)
+ (return (_lux_: SyntaxList
+ (#Cons [(foldL (lambda' [tail head]
+ (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"]))
+ (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])])))
+ #Nil])]))))
+ (_meta (#TagS ["lux" "Nil"]))
+ (reverse xs))
+ #Nil]))))
+
+(defmacro #export (list& xs)
+ (_lux_case (reverse xs)
+ (#Cons [last init])
+ (return (_lux_: SyntaxList
+ (list (foldL (lambda' [tail head]
+ (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"]))
+ (_meta (#TupleS (list head tail)))))))
+ last
+ init))))
+
+ _
+ (fail "Wrong syntax for list&")))
+
+(defmacro #export (lambda tokens)
+ (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax)))
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#SymbolS name)]) tokens'])
+ [name tokens']
+
+ _
+ [["" ""] tokens]))
+ (_lux_case tokens'
+ (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])])
+ (_lux_case args
+ #Nil
+ (fail "lambda requires a non-empty arguments tuple.")
+
+ (#Cons [harg targs])
+ (return (_lux_: SyntaxList
+ (list ($form (list ($symbol ["" "_lux_lambda"])
+ ($symbol name)
+ harg
+ (foldL (lambda' [body' arg]
+ ($form (list ($symbol ["" "_lux_lambda"])
+ ($symbol ["" ""])
+ arg
+ body')))
+ body
+ (reverse targs))))))))
+
+ _
+ (fail "Wrong syntax for lambda"))))
+
+(defmacro (def'' tokens)
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TagS ["" "export"])])
+ (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
+ (#Cons [type (#Cons [body #Nil])])])])
+ (return (_lux_: SyntaxList
+ (list ($form (list ($symbol ["" "_lux_def"])
+ name
+ ($form (list ($symbol ["" "_lux_:"])
+ type
+ ($form (list ($symbol ["lux" "lambda"])
+ name
+ ($tuple args)
+ body))))))
+ ($form (list ($symbol ["" "_lux_export"]) name)))))
+
+ (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
+ (return (_lux_: SyntaxList
+ (list ($form (list ($symbol ["" "_lux_def"])
+ name
+ ($form (list ($symbol ["" "_lux_:"])
+ type
+ body))))
+ ($form (list ($symbol ["" "_lux_export"]) name)))))
+
+ (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
+ (#Cons [type (#Cons [body #Nil])])])
+ (return (_lux_: SyntaxList
+ (list ($form (list ($symbol ["" "_lux_def"])
+ name
+ ($form (list ($symbol ["" "_lux_:"])
+ type
+ ($form (list ($symbol ["lux" "lambda"])
+ name
+ ($tuple args)
+ body)))))))))
+
+ (#Cons [name (#Cons [type (#Cons [body #Nil])])])
+ (return (_lux_: SyntaxList
+ (list ($form (list ($symbol ["" "_lux_def"])
+ name
+ ($form (list ($symbol ["" "_lux_:"]) type body)))))))
+
+ _
+ (fail "Wrong syntax for def")
+ ))
+
+(def'' (as-pairs xs)
+ (All' [a]
+ (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a))))))
+ (_lux_case xs
+ (#Cons [x (#Cons [y xs'])])
+ (#Cons [[x y] (as-pairs xs')])
+
+ _
+ #Nil))
+
+(defmacro #export (let tokens)
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])
+ (return (_lux_: SyntaxList
+ (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax))
+ Syntax)
+ (lambda [body binding]
+ (_lux_case binding
+ [label value]
+ (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body))))))
+ body
+ (foldL (_lux_: (All' [a]
+ (->' ($' List (B' a)) (B' a) ($' List (B' a))))
+ (lambda [tail head] (#Cons [head tail])))
+ #Nil
+ (as-pairs bindings))))))
+
+ _
+ (fail "Wrong syntax for let")))
+
+(def'' #export (map f xs)
+ (All' [a b]
+ (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b))))
+ (_lux_case xs
+ #Nil
+ #Nil
+
+ (#Cons [x xs'])
+ (#Cons [(f x) (map f xs')])))
+
+(def'' #export (any? p xs)
+ (All' [a]
+ (->' (->' (B' a) Bool) ($' List (B' a)) Bool))
+ (_lux_case xs
+ #Nil
+ false
+
+ (#Cons [x xs'])
+ (_lux_case (p x)
+ true true
+ false (any? p xs'))))
+
+(def'' (spliced? token)
+ (->' Syntax Bool)
+ (_lux_case token
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))])
+ true
+
+ _
+ false))
+
+(def'' (wrap-meta content)
+ (->' Syntax Syntax)
+ (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"]))
+ (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1)))))
+ content)))))))
+
+(def'' (untemplate-list tokens)
+ (->' ($' List Syntax) Syntax)
+ (_lux_case tokens
+ #Nil
+ (_meta (#TagS ["lux" "Nil"]))
+
+ (#Cons [token tokens'])
+ (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"]))
+ (_meta (#TupleS (list token (untemplate-list tokens')))))))))
+
+(def'' (list:++ xs ys)
+ (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a))))
+ (_lux_case xs
+ (#Cons [x xs'])
+ (#Cons [x (list:++ xs' ys)])
+
+ #Nil
+ ys))
+
+(defmacro #export ($ tokens)
+ (_lux_case tokens
+ (#Cons [op (#Cons [init args])])
+ (return (_lux_: SyntaxList
+ (list (foldL (lambda [a1 a2] ($form (list op a1 a2)))
+ init
+ args))))
+
+ _
+ (fail "Wrong syntax for $")))
+
+(def'' (splice untemplate tag elems)
+ (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
+ (_lux_case (any? spliced? elems)
+ true
+ (let [elems' (map (_lux_: (->' Syntax Syntax)
+ (lambda [elem]
+ (_lux_case elem
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))])
+ spliced
+
+ _
+ ($form (list ($symbol ["" "_lux_:"])
+ ($symbol ["lux" "SyntaxList"])
+ ($form (list ($symbol ["lux" "list"]) (untemplate elem))))))))
+ elems)]
+ (wrap-meta ($form (list tag
+ ($form (list& ($symbol ["lux" "$"])
+ ($symbol ["lux" "list:++"])
+ elems'))))))
+
+ false
+ (wrap-meta ($form (list tag (untemplate-list (map untemplate elems)))))))
+
+(def'' (untemplate subst token)
+ (->' Text Syntax Syntax)
+ (_lux_case token
+ (#Meta [_ (#BoolS value)])
+ (wrap-meta ($form (list ($tag ["lux" "BoolS"]) (_meta (#BoolS value)))))
+
+ (#Meta [_ (#IntS value)])
+ (wrap-meta ($form (list ($tag ["lux" "IntS"]) (_meta (#IntS value)))))
+
+ (#Meta [_ (#RealS value)])
+ (wrap-meta ($form (list ($tag ["lux" "RealS"]) (_meta (#RealS value)))))
+
+ (#Meta [_ (#CharS value)])
+ (wrap-meta ($form (list ($tag ["lux" "CharS"]) (_meta (#CharS value)))))
+
+ (#Meta [_ (#TextS value)])
+ (wrap-meta ($form (list ($tag ["lux" "TextS"]) (_meta (#TextS value)))))
+
+ (#Meta [_ (#TagS [module name])])
+ (let [module' (_lux_case module
+ ""
+ subst
+
+ _
+ module)]
+ (wrap-meta ($form (list ($tag ["lux" "TagS"]) ($tuple (list ($text module') ($text name)))))))
+
+ (#Meta [_ (#SymbolS [module name])])
+ (let [module' (_lux_case module
+ ""
+ subst
+
+ _
+ module)]
+ (wrap-meta ($form (list ($tag ["lux" "SymbolS"]) ($tuple (list ($text module') ($text name)))))))
+
+ (#Meta [_ (#TupleS elems)])
+ (splice (untemplate subst) ($tag ["lux" "TupleS"]) elems)
+
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])
+ unquoted
+
+ (#Meta [_ (#FormS elems)])
+ (splice (untemplate subst) ($tag ["lux" "FormS"]) elems)
+
+ (#Meta [_ (#RecordS fields)])
+ (wrap-meta ($form (list ($tag ["lux" "RecordS"])
+ (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax)
+ (lambda [kv]
+ (let [[k v] kv]
+ ($tuple (list (untemplate subst k) (untemplate subst v))))))
+ fields)))))
+ ))
+
+(defmacro (`' tokens)
+ (_lux_case tokens
+ (#Cons [template #Nil])
+ (return (_lux_: SyntaxList
+ (list (untemplate "" template))))
+
+ _
+ (fail "Wrong syntax for `'")))
+
+(defmacro #export (|> tokens)
+ (_lux_case tokens
+ (#Cons [init apps])
+ (return (_lux_: SyntaxList
+ (list (foldL (_lux_: (->' Syntax Syntax Syntax)
+ (lambda [acc app]
+ (_lux_case app
+ (#Meta [_ (#FormS parts)])
+ ($form (list:++ parts (list acc)))
+
+ _
+ (`' ((~ app) (~ acc))))))
+ init
+ apps))))
+
+ _
+ (fail "Wrong syntax for |>")))
+
+(defmacro #export (if tokens)
+ (_lux_case tokens
+ (#Cons [test (#Cons [then (#Cons [else #Nil])])])
+ (return (_lux_: SyntaxList
+ (list (`' (_lux_case (~ test)
+ true (~ then)
+ false (~ else))))))
+
+ _
+ (fail "Wrong syntax for if")))
+
+## (deftype (Lux a)
+## (-> Compiler (Either Text (, Compiler a))))
+(def'' #export Lux
+ Type
+ (All' [a]
+ (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a)))))))
+
+## (defsig (Monad m)
+## (: (All [a] (-> a (m a)))
+## return)
+## (: (All [a b] (-> (-> a (m b)) (m a) (m b)))
+## bind))
+(def'' Monad
+ Type
+ (All' [m]
+ (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))]
+ ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b)))
+ ($' (B' m) (B' a))
+ ($' (B' m) (B' b))))]))))
+
+(def'' Maybe:Monad
+ ($' Monad Maybe)
+ {#lux;return
+ (lambda return [x]
+ (#Some x))
+
+ #lux;bind
+ (lambda [f ma]
+ (_lux_case ma
+ #None #None
+ (#Some a) (f a)))})
+
+(def'' Lux:Monad
+ ($' Monad Lux)
+ {#lux;return
+ (lambda [x]
+ (lambda [state]
+ (#Right [state x])))
+
+ #lux;bind
+ (lambda [f ma]
+ (lambda [state]
+ (_lux_case (ma state)
+ (#Left msg)
+ (#Left msg)
+
+ (#Right [state' a])
+ (f a state'))))})
+
+(defmacro #export (^ tokens)
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil])
+ (return (_lux_: SyntaxList
+ (list (`' (#;DataT (~ (_meta (#TextS class-name))))))))
+
+ _
+ (fail "Wrong syntax for ^")))
+
+(defmacro #export (-> tokens)
+ (_lux_case (reverse tokens)
+ (#Cons [output inputs])
+ (return (_lux_: SyntaxList
+ (list (foldL (_lux_: (->' Syntax Syntax Syntax)
+ (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))))
+ output
+ inputs))))
+
+ _
+ (fail "Wrong syntax for ->")))
+
+(defmacro #export (, tokens)
+ (return (_lux_: SyntaxList
+ (list (`' (#;TupleT (;list (~@ tokens))))))))
+
+(defmacro (do tokens)
+ (_lux_case tokens
+ (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])])
+ (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax)
+ (lambda [body' binding]
+ (let [[var value] binding]
+ (_lux_case var
+ (#Meta [_ (#TagS ["" "let"])])
+ (`' (;let (~ value) (~ body')))
+
+ _
+ (`' (;bind (_lux_lambda (~ ($symbol ["" ""]))
+ (~ var)
+ (~ body'))
+ (~ value)))))))
+ body
+ (reverse (as-pairs bindings)))]
+ (return (_lux_: SyntaxList
+ (list (`' (_lux_case (~ monad)
+ {#;return ;return #;bind ;bind}
+ (~ body')))))))
+
+ _
+ (fail "Wrong syntax for do")))
+
+(def'' (map% m f xs)
+ ## (All [m a b]
+ ## (-> (Monad m) (-> a (m b)) (List a) (m (List b))))
+ (All' [m a b]
+ (-> ($' Monad (B' m))
+ (-> (B' a) ($' (B' m) (B' b)))
+ ($' List (B' a))
+ ($' (B' m) ($' List (B' b)))))
+ (let [{#;return ;return #;bind _} m]
+ (_lux_case xs
+ #Nil
+ (;return (_lux_: List #Nil))
+
+ (#Cons [x xs'])
+ (do m
+ [y (f x)
+ ys (map% m f xs')]
+ (;return (_lux_: List (#Cons [y ys]))))
+ )))
+
+(def'' #export (. f g)
+ (All' [a b c]
+ (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c))))
+ (lambda [x]
+ (f (g x))))
+
+(def'' (get-ident x)
+ (-> Syntax ($' Maybe Text))
+ (_lux_case x
+ (#Meta [_ (#SymbolS ["" sname])])
+ (#Some sname)
+
+ _
+ #None))
+
+(def'' (tuple->list tuple)
+ (-> Syntax ($' Maybe ($' List Syntax)))
+ (_lux_case tuple
+ (#Meta [_ (#TupleS members)])
+ (#Some members)
+
+ _
+ #None))
+
+(def'' RepEnv
+ Type
+ ($' List (, Text Syntax)))
+
+(def'' (make-env xs ys)
+ (-> ($' List Text) ($' List Syntax) RepEnv)
+ (_lux_case (_lux_: (, ($' List Text) ($' List Syntax))
+ [xs ys])
+ [(#Cons [x xs']) (#Cons [y ys'])]
+ (#Cons [[x y] (make-env xs' ys')])
+
+ _
+ #Nil))
+
+(def'' (text:= x y)
+ (-> Text Text Bool)
+ (_jvm_invokevirtual java.lang.Object equals [java.lang.Object]
+ x [y]))
+
+(def'' (get-rep key env)
+ (-> Text RepEnv ($' Maybe Syntax))
+ (_lux_case env
+ #Nil
+ #None
+
+ (#Cons [[k v] env'])
+ (if (text:= k key)
+ (#Some v)
+ (get-rep key env'))))
+
+(def'' (apply-template env template)
+ (-> RepEnv Syntax Syntax)
+ (_lux_case template
+ (#Meta [_ (#SymbolS ["" sname])])
+ (_lux_case (get-rep sname env)
+ (#Some subst)
+ subst
+
+ _
+ template)
+
+ (#Meta [_ (#TupleS elems)])
+ ($tuple (map (apply-template env) elems))
+
+ (#Meta [_ (#FormS elems)])
+ ($form (map (apply-template env) elems))
+
+ (#Meta [_ (#RecordS members)])
+ ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax))
+ (lambda [kv]
+ (let [[slot value] kv]
+ [(apply-template env slot) (apply-template env value)])))
+ members))
+
+ _
+ template))
+
+(def'' (join-map f xs)
+ (All' [a b]
+ (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b))))
+ (_lux_case xs
+ #Nil
+ #Nil
+
+ (#Cons [x xs'])
+ (list:++ (f x) (join-map f xs'))))
+
+(defmacro #export (do-template tokens)
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])])
+ (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax))))
+ [(map% Maybe:Monad get-ident bindings)
+ (map% Maybe:Monad tuple->list data)])
+ [(#Some bindings') (#Some data')]
+ (let [apply (_lux_: (-> RepEnv ($' List Syntax))
+ (lambda [env] (map (apply-template env) templates)))]
+ (|> data'
+ (join-map (. apply (make-env bindings')))
+ return))
+
+ _
+ (fail "All the do-template bindigns must be symbols."))
+
+ _
+ (fail "Wrong syntax for do-template")))
+
+(do-template [<name> <cmp> <type>]
+ [(def'' #export (<name> x y)
+ (-> <type> <type> Bool)
+ (<cmp> x y))]
+
+ [int:= _jvm_leq Int]
+ [int:> _jvm_lgt Int]
+ [int:< _jvm_llt Int]
+ [real:= _jvm_deq Real]
+ [real:> _jvm_dgt Real]
+ [real:< _jvm_dlt Real]
+ )
+
+(do-template [<name> <cmp> <type>]
+ [(def'' #export (<name> x y)
+ (-> <type> <type> <type>)
+ (<cmp> x y))]
+
+ [int:+ _jvm_ladd Int]
+ [int:- _jvm_lsub Int]
+ [int:* _jvm_lmul Int]
+ [int:/ _jvm_ldiv Int]
+ [int:% _jvm_lrem Int]
+ [real:+ _jvm_dadd Real]
+ [real:- _jvm_dsub Real]
+ [real:* _jvm_dmul Real]
+ [real:/ _jvm_ddiv Real]
+ [real:% _jvm_drem Real]
+ )
+
+(def'' (multiple? div n)
+ (-> Int Int Bool)
+ (int:= 0 (int:% n div)))
+
+(def'' #export (length list)
+ (-> List Int)
+ (foldL (lambda [acc _] (int:+ 1 acc)) 0 list))
+
+(def'' #export (not x)
+ (-> Bool Bool)
+ (if x false true))
+
+(def'' #export (text:++ x y)
+ (-> Text Text Text)
+ (_jvm_invokevirtual java.lang.String concat [java.lang.String]
+ x [y]))
+
+(def'' (ident->text ident)
+ (-> Ident Text)
+ (let [[module name] ident]
+ ($ text:++ module ";" name)))
+
+(def'' (replace-syntax reps syntax)
+ (-> RepEnv Syntax Syntax)
+ (_lux_case syntax
+ (#Meta [_ (#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_: (-> (, Syntax Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[k v] slot]
+ [(replace-syntax reps k) (replace-syntax reps v)])))
+ slots))])
+
+ _
+ syntax)
+ )
+
+(defmacro #export (All tokens)
+ (let [[self-ident tokens'] (_lux_: (, Text SyntaxList)
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens'])
+ [self-ident tokens']
+
+ _
+ ["" tokens]))]
+ (_lux_case tokens'
+ (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])])
+ (_lux_case (map% Maybe:Monad get-ident args)
+ (#Some idents)
+ (_lux_case idents
+ #Nil
+ (return (_lux_: SyntaxList
+ (list body)))
+
+ (#Cons [harg targs])
+ (let [replacements (map (_lux_: (-> Text (, Text Syntax))
+ (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))]))
+ (list& self-ident idents))
+ body' (foldL (_lux_: (-> Syntax Text Syntax)
+ (lambda [body' arg']
+ (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))))
+ (replace-syntax replacements body)
+ (reverse targs))]
+ (return (_lux_: SyntaxList
+ (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))))
+
+ #None
+ (fail "'All' arguments must be symbols."))
+
+ _
+ (fail "Wrong syntax for All"))
+ ))
+
+(def'' (get k plist)
+ (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'' #export (get-module-name state)
+ ($' Lux Text)
+ (_lux_case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #seen-sources seen-sources #eval? eval?}
+ (_lux_case (reverse envs)
+ #Nil
+ (#Left "Can't get the module name without a module!")
+
+ (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _])
+ (#Right [state module-name]))))
+
+(def'' (find-macro' modules current-module module name)
+ (-> ($' List (, Text ($' Module Compiler)))
+ Text Text Text
+ ($' Maybe Macro))
+ (do Maybe:Monad
+ [$module (get module modules)
+ gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)]
+ (get name bindings))]
+ (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef)
+ [exported? (#MacroD macro')]
+ (if exported?
+ (#Some macro')
+ (if (text:= module current-module)
+ (#Some macro')
+ #None))
+
+ [_ (#AliasD [r-module r-name])]
+ (find-macro' modules current-module r-module r-name)
+
+ _
+ #None)))
+
+(def'' #export (find-macro ident)
+ (-> Ident ($' Lux ($' Maybe Macro)))
+ (do Lux:Monad
+ [current-module get-module-name]
+ (let [[module name] ident]
+ (lambda [state]
+ (_lux_case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #seen-sources seen-sources #eval? eval?}
+ (#Right [state (find-macro' modules current-module module name)]))))))
+
+(def'' (list:join xs)
+ (All [a]
+ (-> ($' List ($' List a)) ($' List a)))
+ (foldL list:++ #Nil xs))
+
+(def'' #export (normalize ident)
+ (-> Ident ($' Lux Ident))
+ (_lux_case ident
+ ["" name]
+ (do Lux:Monad
+ [module-name get-module-name]
+ (;return (_lux_: Ident [module-name name])))
+
+ _
+ (return ident)))
+
+(defmacro #export (| tokens)
+ (do Lux:Monad
+ [pairs (map% Lux:Monad
+ (_lux_: (-> Syntax ($' Lux Syntax))
+ (lambda [token]
+ (_lux_case token
+ (#Meta [_ (#TagS ident)])
+ (do Lux:Monad
+ [ident (normalize ident)]
+ (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (;,)]))))
+
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))])
+ (do Lux:Monad
+ [ident (normalize ident)]
+ (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)]))))
+
+ _
+ (fail "Wrong syntax for |"))))
+ tokens)]
+ (;return (_lux_: SyntaxList
+ (list (`' (#;VariantT (;list (~@ pairs)))))))))
+
+(defmacro #export (& tokens)
+ (if (not (multiple? 2 (length tokens)))
+ (fail "& expects an even number of arguments.")
+ (do Lux:Monad
+ [pairs (map% Lux:Monad
+ (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax))
+ (lambda [pair]
+ (_lux_case pair
+ [(#Meta [_ (#TagS ident)]) value]
+ (do Lux:Monad
+ [ident (normalize ident)]
+ (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)]))))
+
+ _
+ (fail "Wrong syntax for &"))))
+ (as-pairs tokens))]
+ (;return (_lux_: SyntaxList
+ (list (`' (#;RecordT (;list (~@ pairs))))))))))
+
+(def'' #export (->text x)
+ (-> (^ java.lang.Object) Text)
+ (_jvm_invokevirtual java.lang.Object toString [] x []))
+
+(def'' #export (interpose sep xs)
+ (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'' #export (syntax:show syntax)
+ (-> Syntax Text)
+ (_lux_case syntax
+ (#Meta [_ (#BoolS value)])
+ (->text value)
+
+ (#Meta [_ (#IntS value)])
+ (->text value)
+
+ (#Meta [_ (#RealS value)])
+ (->text value)
+
+ (#Meta [_ (#CharS value)])
+ ($ text:++ "#\"" (->text value) "\"")
+
+ (#Meta [_ (#TextS value)])
+ value
+
+ (#Meta [_ (#SymbolS ident)])
+ (ident->text ident)
+
+ (#Meta [_ (#TagS ident)])
+ (text:++ "#" (ident->text ident))
+
+ (#Meta [_ (#TupleS members)])
+ ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) "]")
+
+ (#Meta [_ (#FormS members)])
+ ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) ")")
+
+ (#Meta [_ (#RecordS slots)])
+ ($ text:++ "{"
+ (|> slots
+ (map (_lux_: (-> (, Syntax Syntax) Text)
+ (lambda [slot]
+ (let [[k v] slot]
+ ($ text:++ (syntax:show k) " " (syntax:show v))))))
+ (interpose " ")
+ (foldL text:++ ""))
+ "}")
+ ))
+
+(def'' #export (macro-expand syntax)
+ (-> Syntax ($' Lux ($' List Syntax)))
+ (_lux_case syntax
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))])
+ (do Lux:Monad
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro (_lux_: Ident macro-name'))]
+ (_lux_case (_lux_: ($' Maybe Macro) ?macro)
+ (#Some macro)
+ (do Lux:Monad
+ [expansion (macro args)
+ expansion' (map% Lux:Monad macro-expand (_lux_: SyntaxList expansion))]
+ (;return (_lux_: SyntaxList (list:join (_lux_: ($' List SyntaxList) expansion')))))
+
+ #None
+ (do Lux:Monad
+ [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))]
+ (;return (_lux_: SyntaxList (list ($form (list:join (_lux_: ($' List SyntaxList) parts')))))))))
+
+ (#Meta [_ (#FormS (#Cons [harg targs]))])
+ (do Lux:Monad
+ [harg+ (macro-expand harg)
+ targs+ (map% Lux:Monad macro-expand (_lux_: SyntaxList targs))]
+ (;return (_lux_: SyntaxList (list ($form (list:++ harg+ (list:join (_lux_: ($' List SyntaxList) targs+))))))))
+
+ (#Meta [_ (#TupleS members)])
+ (do Lux:Monad
+ [members' (map% Lux:Monad macro-expand members)]
+ (;return (_lux_: SyntaxList (list ($tuple (list:join (_lux_: ($' List SyntaxList) members')))))))
+
+ _
+ (return (_lux_: SyntaxList (list syntax)))))
+
+(def'' (walk-type type)
+ (-> Syntax Syntax)
+ (_lux_case type
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))])
+ ($form (#Cons [($tag tag) (map walk-type parts)]))
+
+ (#Meta [_ (#TupleS members)])
+ ($tuple (map walk-type members))
+
+ (#Meta [_ (#FormS (#Cons [type-fn args]))])
+ (foldL (_lux_: (-> Syntax Syntax Syntax)
+ (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))))
+ (walk-type type-fn)
+ (map walk-type args))
+
+ _
+ type))
+
+(defmacro #export (type` tokens)
+ (_lux_case tokens
+ (#Cons [type #Nil])
+ (do Lux:Monad
+ [type+ (macro-expand type)]
+ (_lux_case (_lux_: SyntaxList type+)
+ (#Cons [type' #Nil])
+ (;return (_lux_: SyntaxList
+ (list (walk-type type'))))
+
+ _
+ (fail "type`: The expansion of the type-syntax had to yield a single element.")))
+
+ _
+ (fail "Wrong syntax for type`")))
+
+(defmacro #export (: tokens)
+ (_lux_case tokens
+ (#Cons [type (#Cons [value #Nil])])
+ (return (_lux_: SyntaxList
+ (list (`' (_lux_: (;type` (~ type)) (~ value))))))
+
+ _
+ (fail "Wrong syntax for :")))
+
+(defmacro #export (:! tokens)
+ (_lux_case tokens
+ (#Cons [type (#Cons [value #Nil])])
+ (return (: (List Syntax)
+ (list (`' (_lux_:! (;type` (~ type)) (~ value))))))
+
+ _
+ (fail "Wrong syntax for :!")))
+
+(defmacro #export (deftype tokens)
+ (let [[export? tokens'] (: (, Bool (List Syntax))
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
+ [true tokens']
+
+ _
+ [false tokens]))
+ parts (: (Maybe (, Syntax (List Syntax) Syntax))
+ (_lux_case tokens'
+ (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])])
+ (#Some [($symbol name) #Nil type])
+
+ (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])])
+ (#Some [($symbol name) args type])
+
+ _
+ #None))]
+ (_lux_case parts
+ (#Some [name args type])
+ (let [with-export (: (List Syntax)
+ (if export?
+ (list (`' (_lux_export (~ name))))
+ #Nil))
+ type' (: Syntax
+ (_lux_case args
+ #Nil
+ type
+
+ _
+ (`' (;All (~ name) [(~@ args)] (~ type)))))]
+ (return (: (List Syntax)
+ (list& (`' (_lux_def (~ name) (;type` (~ type'))))
+ with-export))))
+
+ #None
+ (fail "Wrong syntax for deftype"))
+ ))
+
+(deftype #export (IO a)
+ (-> (,) a))
+
+(defmacro #export (io tokens)
+ (_lux_case tokens
+ (#Cons [value #Nil])
+ (let [blank ($symbol ["" ""])]
+ (return (_lux_: SyntaxList
+ (list (`' (_lux_lambda (~ blank) (~ blank) (~ value)))))))
+
+ _
+ (fail "Wrong syntax for io")))
+
+(defmacro #export (exec tokens)
+ (_lux_case (reverse tokens)
+ (#Cons [value actions])
+ (let [dummy ($symbol ["" ""])]
+ (return (_lux_: SyntaxList
+ (list (foldL (: (-> Syntax Syntax Syntax)
+ (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))))
+ value
+ actions)))))
+
+ _
+ (fail "Wrong syntax for exec")))
+
+(defmacro #export (def tokens)
+ (let [[export? tokens'] (: (, Bool (List Syntax))
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
+ [true tokens']
+
+ _
+ [false tokens]))
+ parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax))
+ (_lux_case tokens'
+ (#Cons [(#Meta [_ (#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 [(#Meta [_ (#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' (: Syntax
+ (_lux_case args
+ #Nil
+ body
+
+ _
+ (`' (;lambda (~ name) [(~@ args)] (~ body)))))
+ body'' (: Syntax
+ (_lux_case ?type
+ (#Some type)
+ (`' (: (~ type) (~ body')))
+
+ #None
+ body'))]
+ (return (: (List Syntax)
+ (list& (`' (_lux_def (~ name) (~ body'')))
+ (if export?
+ (list (`' (_lux_export (~ name))))
+ #Nil)))))
+
+ #None
+ (fail "Wrong syntax for def"))))
+
+(def (rejoin-pair pair)
+ (-> (, Syntax Syntax) (List Syntax))
+ (let [[left right] pair]
+ (list left right)))
+
+(defmacro #export (case tokens)
+ (_lux_case tokens
+ (#Cons [value branches])
+ (do Lux:Monad
+ [expansions (map% Lux:Monad
+ (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax))))
+ (lambda expander [branch]
+ (let [[pattern body] branch]
+ (_lux_case pattern
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))])
+ (do Lux:Monad
+ [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args)))
+ expansions (map% Lux:Monad expander (as-pairs (: (List Syntax) expansion)))]
+ (;return (: (List (, Syntax Syntax)) (list:join (: (List (List (, Syntax Syntax))) expansions)))))
+
+ _
+ (;return (: (List (, Syntax Syntax)) (list branch)))))))
+ (as-pairs branches))]
+ (;return (_lux_: SyntaxList
+ (list (`' (_lux_case (~ value)
+ (~@ (|> (: (List (List (, Syntax Syntax))) expansions)
+ list:join (map rejoin-pair) list:join))))))))
+
+ _
+ (fail "Wrong syntax for case")))
+
+(defmacro #export (\ tokens)
+ (case tokens
+ (#Cons [body (#Cons [pattern #Nil])])
+ (do Lux:Monad
+ [pattern+ (macro-expand pattern)]
+ (case (: (List Syntax) pattern+)
+ (#Cons [pattern' #Nil])
+ (;return (: (List Syntax)
+ (list pattern' body)))
+
+ _
+ (fail "\\ can only expand to 1 pattern.")))
+
+ _
+ (fail "Wrong syntax for \\")))
+
+(defmacro #export (\or tokens)
+ (case tokens
+ (#Cons [body patterns])
+ (case patterns
+ #Nil
+ (fail "\\or can't have 0 patterns")
+
+ _
+ (do Lux:Monad
+ [patterns' (map% Lux:Monad macro-expand patterns)]
+ (;return (: (List Syntax)
+ (list:join (map (: (-> Syntax (List Syntax))
+ (lambda [pattern] (list pattern body)))
+ (list:join patterns')))))))
+
+ _
+ (fail "Wrong syntax for \\or")))
+
+(do-template [<name> <offset>]
+ [(def #export <name> (int:+ <offset>))]
+
+ [inc 1]
+ [dec -1])
+
+(def (int:show int)
+ (-> Int Text)
+ (_jvm_invokevirtual java.lang.Object toString []
+ int []))
+
+(defmacro #export (` tokens)
+ (do Lux:Monad
+ [module-name get-module-name]
+ (case tokens
+ (\ (list template))
+ (;return (_lux_: SyntaxList
+ (list (untemplate module-name template))))
+
+ _
+ (fail "Wrong syntax for `"))))
+
+(def #export (gensym prefix state)
+ (-> Text (Lux Syntax))
+ (case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #seen-sources seen-sources #eval? eval?}
+ (#Right [{#source source #modules modules
+ #envs envs #types types #host host
+ #seed (inc seed) #seen-sources seen-sources #eval? eval?}
+ ($symbol ["__gensym__" (int:show seed)])])))
+
+(def #export (macro-expand-1 token)
+ (-> Syntax (Lux Syntax))
+ (do Lux:Monad
+ [token+ (macro-expand token)]
+ (case (: (List Syntax) token+)
+ (\ (list token'))
+ (;return token')
+
+ _
+ (fail "Macro expanded to more than 1 element."))))
+
+(defmacro #export (sig tokens)
+ (do Lux:Monad
+ [tokens' (map% Lux:Monad macro-expand-1 tokens)
+ members (map% Lux:Monad
+ (: (-> Syntax (Lux (, Ident Syntax)))
+ (lambda [token]
+ (case token
+ (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))]))
+ (do Lux:Monad
+ [name' (normalize name)]
+ (;return (: (, Ident Syntax) [name' type])))
+
+ _
+ (fail "Signatures require typed members!"))))
+ tokens')]
+ (;return (: (List Syntax)
+ (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax)
+ (lambda [pair]
+ (let [[name type] pair]
+ (`' [(~ (|> name ident->text $text))
+ (~ type)]))))
+ members))))))))))
+
+(defmacro #export (defsig tokens)
+ (let [[export? tokens'] (: (, Bool (List Syntax))
+ (case tokens
+ (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens'))
+ [true tokens']
+
+ _
+ [false tokens]))
+ ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax)))
+ (case tokens'
+ (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs))
+ (#Some [name args sigs])
+
+ (\ (list& name sigs))
+ (#Some [name #Nil sigs])
+
+ _
+ #None))]
+ (case ?parts
+ (#Some [name args sigs])
+ (let [sigs' (: Syntax
+ (case args
+ #Nil
+ (`' (;sig (~@ sigs)))
+
+ _
+ (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))]
+ (return (: (List Syntax)
+ (list& (`' (_lux_def (~ name) (~ sigs')))
+ (if export?
+ (list (`' (_lux_export (~ name))))
+ #Nil)))))
+
+ #None
+ (fail "Wrong syntax for defsig"))))
+
+(defmacro #export (struct tokens)
+ (do Lux:Monad
+ [tokens' (map% Lux:Monad macro-expand-1 tokens)
+ members (map% Lux:Monad
+ (: (-> Syntax (Lux (, Syntax Syntax)))
+ (lambda [token]
+ (case token
+ (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))]))
+ (do Lux:Monad
+ [name' (normalize name)]
+ (;return (: (, Syntax Syntax) [($tag name') value])))
+
+ _
+ (fail "Structures require defined members!"))))
+ tokens')]
+ (;return (: (List Syntax)
+ (list ($record members))))))
+
+(defmacro #export (defstruct tokens)
+ (let [[export? tokens'] (: (, Bool (List Syntax))
+ (case tokens
+ (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens'))
+ [true tokens']
+
+ _
+ [false tokens]))
+ ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax)))
+ (case tokens'
+ (\ (list& (#Meta [_ (#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 defs])
+ (let [defs' (: Syntax
+ (case args
+ #Nil
+ (`' (;struct (~@ defs)))
+
+ _
+ (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))]
+ (return (: (List Syntax)
+ (list& (`' (def (~ name) (~ type) (~ defs')))
+ (if export?
+ (list (`' (_lux_export (~ name))))
+ #Nil)))))
+
+ #None
+ (fail "Wrong syntax for defsig"))))
+
+(defsig #export (Eq a)
+ (: (-> a a Bool)
+ =))
+
+(do-template [<name> <type> <test>]
+ [(defstruct #export <name> (Eq <type>)
+ (def (= x y)
+ (<test> x y)))]
+
+ [Int:Eq Int _jvm_leq]
+ [Real:Eq Real _jvm_deq])
+
+(def #export (id x)
+ (All [a] (-> a a))
+ x)
+
+(defsig #export (Show a)
+ (: (-> a Text)
+ show))
+
+(do-template [<name> <type> <body>]
+ [(defstruct #export <name> (Show <type>)
+ (def (show x)
+ <body>))]
+
+ [Bool:Show Bool (->text x)]
+ [Int:Show Int (->text x)]
+ [Real:Show Real (->text x)]
+ [Char:Show Char ($ text:++ "#\"" (->text x) "\"")])
+
+(defsig #export (Ord a)
+ (: (-> a a Bool)
+ <)
+ (: (-> a a Bool)
+ <=)
+ (: (-> a a Bool)
+ >)
+ (: (-> a a Bool)
+ >=))
+
+(do-template [<name> <form> <message>]
+ [(defmacro #export (<name> tokens)
+ (case (reverse tokens)
+ (\ (list& last init))
+ (return (: (List Syntax)
+ (list (foldL (: (-> Syntax Syntax Syntax)
+ (lambda [post pre] (` <form>)))
+ last
+ init))))
+
+ _
+ (fail <message>)))]
+
+ [and (if (~ pre) true (~ post)) "and requires >=1 clauses."]
+ [or (if (~ pre) (~ post) false) "or requires >=1 clauses."])
+
+(do-template [<name> <type> <lt> <gt> <eq>]
+ [(defstruct #export <name> (Ord <type>)
+ (def (< x y)
+ (<lt> x y))
+
+ (def (<= x y)
+ (or (<lt> x y)
+ (<eq> x y)))
+
+ (def (> x y)
+ (<gt> x y))
+
+ (def (>= x y)
+ (or (<gt> x y)
+ (<eq> x y))))]
+
+ [Int:Ord Int _jvm_llt _jvm_lgt _jvm_leq]
+ [Real:Ord Real _jvm_dlt _jvm_dgt _jvm_deq])
+
+(defmacro #export (lux tokens state)
+ (case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #seen-sources seen-sources #eval? eval?}
+ (case (get "lux" modules)
+ (#Some lux)
+ (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))
+ (List Text))
+ (lambda [gdef]
+ (let [[name [export? _]] gdef]
+ (if export?
+ (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object]
+ (_jvm_getstatic java.lang.System out) [($ text:++ "Importing: " name "\n")])
+ (list name))
+ (list)))))
+ (let [{#module-aliases _ #defs defs #imports _} lux]
+ defs))]
+ (#Right [state (: (List Syntax)
+ (map (: (-> Text Syntax)
+ (lambda [name]
+ (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name]))))))
+ (list:join to-alias)))]))
+
+ #None
+ (#Left "Uh, oh... The universe is not working properly..."))
+ ))
+
+(def #export (print x)
+ (-> Text (IO (,)))
+ (lambda [_]
+ (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object]
+ (_jvm_getstatic java.lang.System out) [x])
+ [])))
+
+(def #export (println x)
+ (-> Text (IO (,)))
+ (print (text:++ x "\n")))
+
+(def #export (some f xs)
+ (All [a b]
+ (-> (-> a (Maybe b)) (List a) (Maybe b)))
+ (case xs
+ #Nil
+ #None
+
+ (#Cons [x xs'])
+ (case (f x)
+ #None
+ (some f xs')
+
+ (#Some y)
+ (#Some y))))
+
+
+(def (index-of part text)
+ (-> Text Text Int)
+ (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String]
+ text [part])))
+
+(def (substring1 idx text)
+ (-> Int Text Text)
+ (_jvm_invokevirtual java.lang.String substring [int]
+ text [(_jvm_l2i idx)]))
+
+(def (substring2 idx1 idx2 text)
+ (-> Int Int Text Text)
+ (_jvm_invokevirtual java.lang.String substring [int int]
+ text [(_jvm_l2i idx1) (_jvm_l2i idx2)]))
+
+(def (split-slot slot)
+ (-> Text (, Text Text))
+ (let [idx (index-of ";" slot)
+ module (substring2 0 idx slot)
+ name (substring1 (inc idx) slot)]
+ [module name]))
+
+(def (resolve-struct-type type)
+ (-> Type (Maybe Type))
+ (case type
+ (#RecordT slots)
+ (#Some type)
+
+ (#AppT [fun arg])
+ (resolve-struct-type fun)
+
+ (#AllT [_ _ _ body])
+ (resolve-struct-type body)
+
+ _
+ #None))
+
+(defmacro #export (using tokens state)
+ (case tokens
+ (\ (list struct body))
+ (case struct
+ (#Meta [_ (#SymbolS vname)])
+ (let [vname' (ident->text vname)]
+ (case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #seen-sources seen-sources #eval? eval?}
+ (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
+ (lambda [env]
+ (case env
+ {#name _ #inner-closures _ #locals {#counter _ #mappings mappings} #closure _}
+ (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
+ (lambda [binding]
+ (let [[bname [_ type]] binding]
+ (if (text:= vname' bname)
+ (#Some type)
+ #None))))
+ mappings))))
+ envs)]
+ (case ?struct-type
+ #None
+ (#Left ($ text:++ "Unknown structure: " vname'))
+
+ (#Some struct-type)
+ (case (resolve-struct-type struct-type)
+ (#Some (#RecordT slots))
+ (let [pattern ($record (map (: (-> (, Text Type) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[sname stype] slot
+ [module name] (split-slot sname)]
+ [($tag [module name]) ($symbol ["" name])])))
+ slots))]
+ (#Right [state (: (List Syntax)
+ (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))]))
+
+ _
+ (#Left "Can only \"use\" records."))))))
+
+ _
+ (let [dummy ($symbol ["" ""])]
+ (#Right [state (: (List Syntax)
+ (list (` (_lux_case (~ struct)
+ (~ dummy)
+ (using (~ dummy)
+ (~ body))))))])))
+
+ _
+ (#Left "Wrong syntax for defsig")))
+
+(def #export (flip f)
+ (All [a b c]
+ (-> (-> a b c) (-> b a c)))
+ (lambda [y x]
+ (f x y)))
+
+## (def #export (curry f)
+## (All [a b c]
+## (-> (-> (, a b) c)
+## (-> a b c)))
+## (lambda [x y]
+## (f [x y])))
+
+## (def #export (uncurry f)
+## (All [a b c]
+## (-> (-> a b c)
+## (-> (, a b) c)))
+## (lambda [[x y]]
+## (f x y)))
+
+## (defmacro (loop tokens)
+## (_lux_case tokens
+## (#Cons [bindings (#Cons [body #Nil])])
+## (let [pairs (as-pairs bindings)]
+## (return (list (#FormS (#Cons [(` (lambda (~ (#SymbolS ["" "recur"])) (~ (#TupleS (map first pairs)))
+## (~ body)))
+## (map second pairs)])))))))
+
+## (defmacro (get@ tokens)
+## (let [output (_lux_case tokens
+## (#Cons [tag (#Cons [record #Nil])])
+## (` (get@' (~ tag) (~ record)))
+
+## (#Cons [tag #Nil])
+## (` (lambda [record] (get@' (~ tag) record))))]
+## (return (list output))))
+
+## (defmacro (set@ tokens)
+## (let [output (_lux_case tokens
+## (#Cons [tag (#Cons [value (#Cons [record #Nil])])])
+## (` (set@' (~ tag) (~ value) (~ record)))
+
+## (#Cons [tag (#Cons [value #Nil])])
+## (` (lambda [record] (set@' (~ tag) (~ value) record)))
+
+## (#Cons [tag #Nil])
+## (` (lambda [value record] (set@' (~ tag) value record))))]
+## (return (list output))))
+
+## (defmacro (update@ tokens)
+## (let [output (_lux_case tokens
+## (#Cons [tag (#Cons [func (#Cons [record #Nil])])])
+## (` (let [_record_ (~ record)]
+## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_)))
+
+## (#Cons [tag (#Cons [func #Nil])])
+## (` (lambda [record]
+## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record))))
+
+## (#Cons [tag #Nil])
+## (` (lambda [func record]
+## (set@' (~ tag) (func (get@' (~ tag) record)) record))))]
+## (return (list output))))
diff --git a/input/program.lux b/input/program.lux
new file mode 100644
index 000000000..4f329c3fa
--- /dev/null
+++ b/input/program.lux
@@ -0,0 +1,15 @@
+(;lux)
+
+(def (filter p xs)
+ (All [a] (-> (-> a Bool) (List a) (List a)))
+ (case xs
+ #;Nil
+ (list)
+
+ (#;Cons [x xs'])
+ (if (p x)
+ (list& x (filter p xs'))
+ (filter p xs'))))
+
+(_jvm_program args
+ (println "Hello, world!"))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 04:56:19 +0000