From 4cd9b0c9242f1105e50ad9b42b7f6f5d074f14b4 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sat, 25 Jul 2015 20:19:43 -0400
Subject: - The output directory is now being used as the cache. - "input" has
been renamed as "source" and "output" has been renamed as "target".
---
input/lux.lux | 2784 ----------------------------------------
input/lux/codata/stream.lux | 133 --
input/lux/control/comonad.lux | 54 -
input/lux/control/functor.lux | 15 -
input/lux/control/lazy.lux | 47 -
input/lux/control/monad.lux | 99 --
input/lux/control/monoid.lux | 24 -
input/lux/data/bool.lux | 33 -
input/lux/data/bounded.lux | 17 -
input/lux/data/char.lux | 20 -
input/lux/data/dict.lux | 83 --
input/lux/data/either.lux | 46 -
input/lux/data/eq.lux | 14 -
input/lux/data/error.lux | 34 -
input/lux/data/id.lux | 28 -
input/lux/data/io.lux | 51 -
input/lux/data/list.lux | 250 ----
input/lux/data/maybe.lux | 42 -
input/lux/data/number.lux | 119 --
input/lux/data/ord.lux | 44 -
input/lux/data/reader.lux | 33 -
input/lux/data/show.lux | 14 -
input/lux/data/state.lux | 35 -
input/lux/data/text.lux | 146 ---
input/lux/data/writer.lux | 34 -
input/lux/host/java.lux | 312 -----
input/lux/math.lux | 60 -
input/lux/meta/lux.lux | 287 -----
input/lux/meta/macro.lux | 54 -
input/lux/meta/syntax.lux | 262 ----
input/program.lux | 48 -
source/lux.lux | 2784 ++++++++++++++++++++++++++++++++++++++++
source/lux/codata/stream.lux | 133 ++
source/lux/control/comonad.lux | 54 +
source/lux/control/functor.lux | 15 +
source/lux/control/lazy.lux | 47 +
source/lux/control/monad.lux | 99 ++
source/lux/control/monoid.lux | 24 +
source/lux/data/bool.lux | 33 +
source/lux/data/bounded.lux | 17 +
source/lux/data/char.lux | 20 +
source/lux/data/dict.lux | 83 ++
source/lux/data/either.lux | 46 +
source/lux/data/eq.lux | 14 +
source/lux/data/error.lux | 34 +
source/lux/data/id.lux | 28 +
source/lux/data/io.lux | 51 +
source/lux/data/list.lux | 250 ++++
source/lux/data/maybe.lux | 42 +
source/lux/data/number.lux | 119 ++
source/lux/data/ord.lux | 44 +
source/lux/data/reader.lux | 33 +
source/lux/data/show.lux | 14 +
source/lux/data/state.lux | 35 +
source/lux/data/text.lux | 146 +++
source/lux/data/writer.lux | 34 +
source/lux/host/java.lux | 312 +++++
source/lux/math.lux | 60 +
source/lux/meta/lux.lux | 287 +++++
source/lux/meta/macro.lux | 54 +
source/lux/meta/syntax.lux | 262 ++++
source/program.lux | 48 +
src/lux.clj | 4 +-
src/lux/analyser/host.clj | 6 +-
src/lux/analyser/lux.clj | 2 +-
src/lux/compiler.clj | 34 +-
src/lux/compiler/base.clj | 144 +--
src/lux/compiler/cache.clj | 135 ++
68 files changed, 5387 insertions(+), 5382 deletions(-)
delete mode 100644 input/lux.lux
delete mode 100644 input/lux/codata/stream.lux
delete mode 100644 input/lux/control/comonad.lux
delete mode 100644 input/lux/control/functor.lux
delete mode 100644 input/lux/control/lazy.lux
delete mode 100644 input/lux/control/monad.lux
delete mode 100644 input/lux/control/monoid.lux
delete mode 100644 input/lux/data/bool.lux
delete mode 100644 input/lux/data/bounded.lux
delete mode 100644 input/lux/data/char.lux
delete mode 100644 input/lux/data/dict.lux
delete mode 100644 input/lux/data/either.lux
delete mode 100644 input/lux/data/eq.lux
delete mode 100644 input/lux/data/error.lux
delete mode 100644 input/lux/data/id.lux
delete mode 100644 input/lux/data/io.lux
delete mode 100644 input/lux/data/list.lux
delete mode 100644 input/lux/data/maybe.lux
delete mode 100644 input/lux/data/number.lux
delete mode 100644 input/lux/data/ord.lux
delete mode 100644 input/lux/data/reader.lux
delete mode 100644 input/lux/data/show.lux
delete mode 100644 input/lux/data/state.lux
delete mode 100644 input/lux/data/text.lux
delete mode 100644 input/lux/data/writer.lux
delete mode 100644 input/lux/host/java.lux
delete mode 100644 input/lux/math.lux
delete mode 100644 input/lux/meta/lux.lux
delete mode 100644 input/lux/meta/macro.lux
delete mode 100644 input/lux/meta/syntax.lux
delete mode 100644 input/program.lux
create mode 100644 source/lux.lux
create mode 100644 source/lux/codata/stream.lux
create mode 100644 source/lux/control/comonad.lux
create mode 100644 source/lux/control/functor.lux
create mode 100644 source/lux/control/lazy.lux
create mode 100644 source/lux/control/monad.lux
create mode 100644 source/lux/control/monoid.lux
create mode 100644 source/lux/data/bool.lux
create mode 100644 source/lux/data/bounded.lux
create mode 100644 source/lux/data/char.lux
create mode 100644 source/lux/data/dict.lux
create mode 100644 source/lux/data/either.lux
create mode 100644 source/lux/data/eq.lux
create mode 100644 source/lux/data/error.lux
create mode 100644 source/lux/data/id.lux
create mode 100644 source/lux/data/io.lux
create mode 100644 source/lux/data/list.lux
create mode 100644 source/lux/data/maybe.lux
create mode 100644 source/lux/data/number.lux
create mode 100644 source/lux/data/ord.lux
create mode 100644 source/lux/data/reader.lux
create mode 100644 source/lux/data/show.lux
create mode 100644 source/lux/data/state.lux
create mode 100644 source/lux/data/text.lux
create mode 100644 source/lux/data/writer.lux
create mode 100644 source/lux/host/java.lux
create mode 100644 source/lux/math.lux
create mode 100644 source/lux/meta/lux.lux
create mode 100644 source/lux/meta/macro.lux
create mode 100644 source/lux/meta/syntax.lux
create mode 100644 source/program.lux
create mode 100644 src/lux/compiler/cache.clj
diff --git a/input/lux.lux b/input/lux.lux
deleted file mode 100644
index 61d99396c..000000000
--- a/input/lux.lux
+++ /dev/null
@@ -1,2784 +0,0 @@
-## 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"]))
-
-## 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 Unit (#TupleT #Nil))
-(_lux_export Unit)
-
-(_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])]))])]))
-(_lux_export Bindings)
-
-## (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])])])]))])]))
-(_lux_export Env)
-
-## (deftype Cursor
-## (, Text Int Int))
-(_lux_def Cursor
- (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])])))
-(_lux_export Cursor)
-
-## (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])])])]))]))
-(_lux_export DefData')
-
-## (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
-## #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;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 _cursor
-## Cursor
-## ["" -1 -1])
-(_lux_def _cursor
- (_lux_: Cursor ["" -1 -1]))
-
-## (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 [_cursor 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 (#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 (#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 (#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 (#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 (#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 (#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 (#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' (defmacro tokens)
- Macro
- (_lux_case tokens
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])
- (return (#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 (#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 #Nil))
-
-(defmacro (->' tokens)
- (_lux_case tokens
- (#Cons [input (#Cons [output #Nil])])
- (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"]))
- (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])])))
- #Nil])])))
- #Nil]))
-
- (#Cons [input (#Cons [output others])])
- (return (#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 (#Cons [body
- #Nil]))
-
- (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))])
- (#Cons [body #Nil])])
- (return (#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 (#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 (#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' (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' (reverse list)
- (All' [a]
- (->' ($' List (B' a)) ($' List (B' a))))
- (foldL (lambda' [tail head] (#Cons [head tail]))
- #Nil
- list))
-
-(defmacro (list xs)
- (return (#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 (list& xs)
- (_lux_case (reverse xs)
- (#Cons [last init])
- (return (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 (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 (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 (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 (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 (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 (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax))
- Syntax)
- (lambda [body binding]
- (_lux_case binding
- [label value]
- (form$ (list (symbol$ ["" "_lux_case"]) value label body)))))
- body
- (reverse (as-pairs bindings)))))
-
- _
- (fail "Wrong syntax for let")))
-
-(def'' (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'' (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'' #export (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 (list (foldL (lambda [a1 a2] (form$ (list op a1 a2)))
- init
- args)))
-
- _
- (fail "Wrong syntax for $")))
-
-(def'' (splice replace? untemplate tag elems)
- (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
- (_lux_case replace?
- true
- (_lux_case (any? spliced? elems)
- true
- (let [elems' (map (lambda [elem]
- (_lux_case elem
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))])
- spliced
-
- _
- (form$ (list (symbol$ ["" "_lux_:"])
- (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"])))))
- (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem)
- (tag$ ["lux" "Nil"])))))))))
- 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))))))
- false
- (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))))
-
-(def'' (untemplate replace? subst token)
- (->' Bool Text Syntax Syntax)
- (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? 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 replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems)
-
- [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])]
- unquoted
-
- [_ (#Meta [_ (#FormS elems)])]
- (splice replace? (untemplate replace? 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 replace? subst k) (untemplate replace? subst v))))))
- fields)))))
- ))
-
-(defmacro (`' tokens)
- (_lux_case tokens
- (#Cons [template #Nil])
- (return (list (untemplate true "" template)))
-
- _
- (fail "Wrong syntax for `'")))
-
-(defmacro (' tokens)
- (_lux_case tokens
- (#Cons [template #Nil])
- (return (list (untemplate false "" template)))
-
- _
- (fail "Wrong syntax for '")))
-
-(defmacro #export (|> tokens)
- (_lux_case tokens
- (#Cons [init apps])
- (return (list (foldL (lambda [acc app]
- (_lux_case app
- (#Meta [_ (#TupleS parts)])
- (tuple$ (list:++ parts (list acc)))
-
- (#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 (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 (list (`' (#;DataT (~ (_meta (#TextS class-name)))))))
-
- _
- (fail "Wrong syntax for ^")))
-
-(defmacro #export (-> tokens)
- (_lux_case (reverse tokens)
- (#Cons [output inputs])
- (return (list (foldL (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))
- output
- inputs)))
-
- _
- (fail "Wrong syntax for ->")))
-
-(defmacro #export (, tokens)
- (return (list (`' (#;TupleT (~ (untemplate-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 (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 #Nil)
-
- (#Cons [x xs'])
- (do m
- [y (f x)
- ys (map% m f xs')]
- (;return (#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'' #export (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 "Wrong syntax for do-template"))
-
- _
- (fail "Wrong syntax for do-template")))
-
-(do-template [<name> <cmp> <type>]
- [(def'' #export (<name> x y)
- (-> <type> <type> Bool)
- (<cmp> x y))]
-
- [i= _jvm_leq Int]
- [i> _jvm_lgt Int]
- [i< _jvm_llt Int]
- [r= _jvm_deq Real]
- [r> _jvm_dgt Real]
- [r< _jvm_dlt Real]
- )
-
-(do-template [<name> <cmp> <eq> <type>]
- [(def'' #export (<name> x y)
- (-> <type> <type> Bool)
- (if (<cmp> x y)
- true
- (<eq> x y)))]
-
- [i>= i> i= Int]
- [i<= i< i= Int]
- [r>= r> r= Real]
- [r<= r< r= Real]
- )
-
-(do-template [<name> <cmp> <type>]
- [(def'' #export (<name> x y)
- (-> <type> <type> <type>)
- (<cmp> x y))]
-
- [i+ _jvm_ladd Int]
- [i- _jvm_lsub Int]
- [i* _jvm_lmul Int]
- [i/ _jvm_ldiv Int]
- [i% _jvm_lrem Int]
- [r+ _jvm_dadd Real]
- [r- _jvm_dsub Real]
- [r* _jvm_dmul Real]
- [r/ _jvm_ddiv Real]
- [r% _jvm_drem Real]
- )
-
-(def'' (multiple? div n)
- (-> Int Int Bool)
- (i= 0 (i% n div)))
-
-(def'' (length list)
- (-> List Int)
- (foldL (lambda [acc _] (i+ 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 (list body))
-
- (#Cons [harg targs])
- (let [replacements (map (_lux_: (-> Text (, Text Syntax))
- (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))]))
- (list& self-ident idents))
- body' (foldL (lambda [body' arg']
- (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')])))
- (replace-syntax replacements body)
- (reverse targs))]
- ## (#;Some #;Nil)
- (return (list (`' (#;AllT [#;None (~ (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'' (put k v dict)
- (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'' (get-module-name state)
- ($' Lux Text)
- (_lux_case state
- {#source source #modules modules
- #envs envs #types types #host host
- #seed seed #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'' (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 #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'' (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 (`' [(~ (text$ (ident->text ident))) (;,)])))
-
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))])
- (do Lux/Monad
- [ident (normalize ident)]
- (;return (`' [(~ (text$ (ident->text ident))) (~ value)])))
-
- _
- (fail "Wrong syntax for |"))))
- tokens)]
- (;return (list (`' (#;VariantT (~ (untemplate-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 (`' [(~ (text$ (ident->text ident))) (~ value)])))
-
- _
- (fail "Wrong syntax for &"))))
- (as-pairs tokens))]
- (;return (list (`' (#;RecordT (~ (untemplate-list pairs)))))))))
-
-(def'' #export (->text x)
- (-> (^ java.lang.Object) Text)
- (_jvm_invokevirtual java.lang.Object toString [] x []))
-
-(def'' (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'' (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 macro-name')]
- (_lux_case ?macro
- (#Some macro)
- (do Lux/Monad
- [expansion (macro args)
- expansion' (map% Lux/Monad macro-expand expansion)]
- (;return (list:join expansion')))
-
- #None
- (do Lux/Monad
- [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))]
- (;return (list (form$ (list:join parts')))))))
-
- (#Meta [_ (#FormS (#Cons [harg targs]))])
- (do Lux/Monad
- [harg+ (macro-expand harg)
- targs+ (map% Lux/Monad macro-expand targs)]
- (;return (list (form$ (list:++ harg+ (list:join targs+))))))
-
- (#Meta [_ (#TupleS members)])
- (do Lux/Monad
- [members' (map% Lux/Monad macro-expand members)]
- (;return (list (tuple$ (list:join members')))))
-
- _
- (return (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 (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 type+
- (#Cons [type' #Nil])
- (;return (list (walk-type type')))
-
- _
- (fail "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 (list (`' (_lux_: (;type (~ type)) (~ value)))))
-
- _
- (fail "Wrong syntax for :")))
-
-(defmacro #export (:! tokens)
- (_lux_case tokens
- (#Cons [type (#Cons [value #Nil])])
- (return (list (`' (_lux_:! (;type (~ type)) (~ value)))))
-
- _
- (fail "Wrong syntax for :!")))
-
-(def'' (empty? xs)
- (All [a] (-> ($' List a) Bool))
- (_lux_case xs
- #Nil true
- _ false))
-
-(defmacro #export (deftype tokens)
- (let [[export? tokens'] (: (, Bool (List Syntax))
- (_lux_case tokens
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
- [true tokens']
-
- _
- [false tokens]))
- [rec? tokens'] (: (, Bool (List Syntax))
- (_lux_case tokens'
- (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens'])
- [true tokens']
-
- _
- [false tokens']))
- parts (: (Maybe (, Text (List Syntax) Syntax))
- (_lux_case tokens'
- (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])])
- (#Some [name #Nil type])
-
- (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])])
- (#Some [name args type])
-
- _
- #None))]
- (_lux_case parts
- (#Some [name args type])
- (let [with-export (: (List Syntax)
- (if export?
- (list (`' (_lux_export (~ (symbol$ ["" name])))))
- #Nil))
- type' (: (Maybe Syntax)
- (if rec?
- (if (empty? args)
- (let [g!param (symbol$ ["" ""])
- prime-name (symbol$ ["" (text:++ name "'")])
- type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)]
- (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+))
- ;Void))))
- #None)
- (_lux_case args
- #Nil
- (#Some type)
-
- _
- (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))]
- (_lux_case type'
- (#Some type'')
- (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type''))))
- with-export))
-
- #None
- (fail "Wrong syntax for deftype")))
-
- #None
- (fail "Wrong syntax for deftype"))
- ))
-## (defmacro #export (deftype tokens)
-## (let [[export? tokens'] (: (, Bool (List Syntax))
-## (_lux_case (:! (List Syntax) tokens)
-## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
-## [true (:! (List Syntax) tokens')]
-
-## _
-## [false (:! (List Syntax) 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& (`' (_lux_def (~ name) (;type (~ type'))))
-## with-export)))
-
-## #None
-## (fail "Wrong syntax for deftype"))
-## ))
-
-(defmacro #export (exec tokens)
- (_lux_case (reverse tokens)
- (#Cons [value actions])
- (let [dummy (symbol$ ["" ""])]
- (return (list (foldL (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& (`' (_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 expansion))]
- (;return (list:join expansions)))
-
- _
- (;return (list branch))))))
- (as-pairs branches))]
- (;return (list (`' (_lux_case (~ value)
- (~@ (|> 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 pattern+
- (#Cons [pattern' #Nil])
- (;return (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:join (map (lambda [pattern] (list pattern body))
- (list:join patterns'))))))
-
- _
- (fail "Wrong syntax for \\or")))
-
-(do-template [<name> <offset>]
- [(def #export <name> (i+ <offset>))]
-
- [inc 1]
- [dec -1])
-
-(defmacro #export (` tokens)
- (do Lux/Monad
- [module-name get-module-name]
- (case tokens
- (\ (list template))
- (;return (list (untemplate true module-name template)))
-
- _
- (fail "Wrong syntax for `"))))
-
-(def (gensym prefix state)
- (-> Text (Lux Syntax))
- (case state
- {#source source #modules modules
- #envs envs #types types #host host
- #seed seed #eval? eval?}
- (#Right [{#source source #modules modules
- #envs envs #types types #host host
- #seed (inc seed) #eval? eval?}
- (symbol$ ["__gensym__" (->text seed)])])))
-
-(def (macro-expand-1 token)
- (-> Syntax (Lux Syntax))
- (do Lux/Monad
- [token+ (macro-expand token)]
- (case 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 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!"))))
- (list:join tokens'))]
- (;return (list (`' (#;RecordT (~ (untemplate-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& (`' (_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 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!"))))
- (list:join tokens'))]
- (;return (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& (`' (def (~ name) (~ type) (~ defs')))
- (if export?
- (list (`' (_lux_export (~ name))))
- #Nil))))
-
- #None
- (fail "Wrong syntax for defstruct"))))
-
-(def #export (id x)
- (All [a] (-> a a))
- x)
-
-(do-template [<name> <form> <message>]
- [(defmacro #export (<name> tokens)
- (case (reverse tokens)
- (\ (list& last init))
- (return (list (foldL (lambda [post pre] (` <form>))
- last
- init)))
-
- _
- (fail <message>)))]
-
- [and (if (~ pre) (~ post) false) "and requires >=1 clauses."]
- [or (if (~ pre) true (~ post)) "or requires >=1 clauses."])
-
-(deftype Referrals
- (| #All
- (#Only (List Text))
- (#Except (List Text))
- #Nothing))
-
-(deftype Import
- (, Text (Maybe Text) Referrals))
-
-(def (extract-defs defs)
- (-> (List Syntax) (Lux (List Text)))
- (map% Lux/Monad
- (: (-> Syntax (Lux Text))
- (lambda [def]
- (case def
- (#Meta [_ (#SymbolS ["" name])])
- (return name)
-
- _
- (fail "only/except requires symbols."))))
- defs))
-
-(def (parse-alias tokens)
- (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax))))
- (case tokens
- (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens'))
- (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens']))
-
- _
- (return (: (, (Maybe Text) (List Syntax)) [#None tokens]))))
-
-(def (parse-referrals tokens)
- (-> (List Syntax) (Lux (, Referrals (List Syntax))))
- (case tokens
- (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens'))
- (case referral
- (#Meta [_ (#TagS ["" "all"])])
- (return (: (, Referrals (List Syntax)) [#All tokens']))
-
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))]))
- (do Lux/Monad
- [defs' (extract-defs defs)]
- (return (: (, Referrals (List Syntax)) [(#Only defs') tokens'])))
-
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "except"])]) defs))]))
- (do Lux/Monad
- [defs' (extract-defs defs)]
- (return (: (, Referrals (List Syntax)) [(#Except defs') tokens'])))
-
- _
- (fail "Incorrect syntax for referral."))
-
- _
- (return (: (, Referrals (List Syntax)) [#Nothing tokens]))))
-
-(def (decorate-imports super-name tokens)
- (-> Text (List Syntax) (Lux (List Syntax)))
- (map% Lux/Monad
- (: (-> Syntax (Lux Syntax))
- (lambda [token]
- (case token
- (#Meta [_ (#SymbolS ["" sub-name])])
- (return (symbol$ ["" ($ text:++ super-name "/" sub-name)]))
-
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))]))
- (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts)))
-
- _
- (fail "Wrong import syntax."))))
- tokens))
-
-(def (parse-imports imports)
- (-> (List Syntax) (Lux (List Import)))
- (do Lux/Monad
- [referrals' (map% Lux/Monad
- (: (-> Syntax (Lux (List Import)))
- (lambda [token]
- (case token
- (#Meta [_ (#SymbolS ["" m-name])])
- (;return (list [m-name #None #All]))
-
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))]))
- (do Lux/Monad
- [alias+extra' (parse-alias extra)
- #let [[alias extra'] (: (, (Maybe Text) (List Syntax))
- alias+extra')]
- referral+extra'' (parse-referrals extra')
- #let [[referral extra''] (: (, Referrals (List Syntax))
- referral+extra'')]
- extra''' (decorate-imports m-name extra'')
- sub-imports (parse-imports extra''')]
- (;return (case referral
- #Nothing (case alias
- #None sub-imports
- (#Some _) (list& [m-name alias referral] sub-imports))
- _ (list& [m-name alias referral] sub-imports))))
-
- _
- (fail "Wrong syntax for import"))))
- imports)]
- (;return (list:join referrals'))))
-
-(def (module-exists? module state)
- (-> Text (Lux Bool))
- (case state
- {#source source #modules modules
- #envs envs #types types #host host
- #seed seed #eval? eval?}
- (case (get module modules)
- (#Some =module)
- (#Right [state true])
-
- #None
- (#Right [state false]))
- ))
-
-(def (exported-defs module state)
- (-> Text (Lux (List Text)))
- (case state
- {#source source #modules modules
- #envs envs #types types #host host
- #seed seed #eval? eval?}
- (case (get module modules)
- (#Some =module)
- (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))
- (List Text))
- (lambda [gdef]
- (let [[name [export? _]] gdef]
- (if export?
- (list name)
- (list)))))
- (let [{#module-aliases _ #defs defs #imports _} =module]
- defs))]
- (#Right [state (list:join to-alias)]))
-
- #None
- (#Left ($ text:++ "Unknown module: " module)))
- ))
-
-(def (last-index-of part text)
- (-> Text Text Int)
- (_jvm_i2l (_jvm_invokevirtual java.lang.String lastIndexOf [java.lang.String]
- text [part])))
-
-(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-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)
- (#Cons [module #Nil])
- (#Cons [(substring2 0 idx module)
- (split-module (substring1 (inc idx) module))]))))
-
-(def (@ idx xs)
- (All [a]
- (-> Int (List a) (Maybe a)))
- (case xs
- #Nil
- #None
-
- (#Cons [x xs'])
- (if (i= idx 0)
- (#Some x)
- (@ (dec idx) xs')
- )))
-
-(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 (clean-module module)
- (-> Text (Lux Text))
- (do Lux/Monad
- [module-name get-module-name]
- (case (split-module module)
- (\ (list& "." parts))
- (return (|> (list& module-name parts) (interpose "/") (foldL text:++ "")))
-
- parts
- (let [[ups parts'] (split-with (text:= "..") parts)
- num-ups (length ups)]
- (if (i= num-ups 0)
- (return module)
- (case (@ num-ups (split-module-contexts module-name))
- #None
- (fail (text:++ "Can't clean module: " module))
-
- (#Some top-module)
- (return (|> (list& top-module parts') (interpose "/") (foldL text:++ ""))))
- )))
- ))
-
-(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 (foldL (lambda [prev case]
- (or prev
- (text:= case name)))
- false
- cases)]
- output))
-
-(defmacro #export (import tokens)
- (do Lux/Monad
- [imports (parse-imports tokens)
- imports (map% Lux/Monad
- (: (-> Import (Lux Import))
- (lambda [import]
- (case import
- [m-name m-alias m-referrals]
- (do Lux/Monad
- [m-name (clean-module m-name)]
- (;return (: Import [m-name m-alias m-referrals]))))))
- imports)
- unknowns' (map% Lux/Monad
- (: (-> Import (Lux (List Text)))
- (lambda [import]
- (case import
- [m-name _ _]
- (do Lux/Monad
- [? (module-exists? m-name)]
- (;return (if ?
- (list)
- (list m-name)))))))
- imports)
- #let [unknowns (list:join unknowns')]]
- (case unknowns
- #Nil
- (do Lux/Monad
- [output' (map% Lux/Monad
- (: (-> Import (Lux (List Syntax)))
- (lambda [import]
- (case import
- [m-name m-alias m-referrals]
- (do Lux/Monad
- [defs (case m-referrals
- #All
- (exported-defs m-name)
-
- (#Only +defs)
- (do Lux/Monad
- [*defs (exported-defs m-name)]
- (;return (filter (is-member? +defs) *defs)))
-
- (#Except -defs)
- (do Lux/Monad
- [*defs (exported-defs m-name)]
- (;return (filter (. not (is-member? -defs)) *defs)))
-
- #Nothing
- (;return (list)))]
- (;return ($ list:++
- (list (` (_lux_import (~ (text$ m-name)))))
- (case m-alias
- #None (list)
- (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))
- (map (: (-> Text Syntax)
- (lambda [def]
- (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def]))))))
- defs)))))))
- imports)]
- (;return (list:join output')))
-
- _
- (;return (: (List Syntax)
- (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name)))))
- unknowns)
- (list (` (import (~@ tokens))))))))))
-
-(def (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 (split-slot slot)
- (-> Text (, Text Text))
- (let [idx (index-of ";" slot)
- module (substring2 0 idx slot)
- name (substring1 (inc idx) slot)]
- [module name]))
-
-(def (type:show type)
- (-> Type Text)
- (case type
- (#DataT name)
- ($ text:++ "(^ " name ")")
-
- (#TupleT elems)
- (case elems
- #;Nil
- "(,)"
-
- _
- ($ text:++ "(, " (|> elems (map type:show) (interpose " ") (foldL text:++ "")) ")"))
-
- (#VariantT cases)
- (case cases
- #;Nil
- "(|)"
-
- _
- ($ text:++ "(| "
- (|> cases
- (map (: (-> (, Text Type) Text)
- (lambda [kv]
- (case kv
- [k (#TupleT #;Nil)]
- ($ text:++ "#" k)
-
- [k v]
- ($ text:++ "(#" k " " (type:show v) ")")))))
- (interpose " ")
- (foldL text:++ ""))
- ")"))
-
- (#RecordT fields)
- (case fields
- #;Nil
- "(&)"
-
- _
- ($ text:++ "(& "
- (|> fields
- (map (: (-> (, Text Type) Text)
- (: (-> (, Text Type) Text)
- (lambda [kv]
- (let [[k v] kv]
- ($ text:++ "(#" k " " (type:show v) ")"))))))
- (interpose " ")
- (foldL text:++ ""))
- ")"))
-
- (#LambdaT [input output])
- ($ text:++ "(-> " (type:show input) " " (type:show output) ")")
-
- (#VarT id)
- ($ text:++ "⌈" (->text id) "⌋")
-
- (#BoundT name)
- name
-
- (#ExT ?id)
- ($ text:++ "⟨" (->text ?id) "⟩")
-
- (#AppT [?lambda ?param])
- ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")")
-
- (#AllT [?env ?name ?arg ?body])
- ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")")
- ))
-
-(def (beta-reduce env type)
- (-> (List (, Text Type)) Type Type)
- (case type
- (#VariantT ?cases)
- (#VariantT (map (: (-> (, Text Type) (, Text Type))
- (lambda [kv]
- (let [[k v] kv]
- [k (beta-reduce env v)])))
- ?cases))
-
- (#RecordT ?fields)
- (#RecordT (map (: (-> (, Text Type) (, Text Type))
- (lambda [kv]
- (let [[k v] kv]
- [k (beta-reduce env v)])))
- ?fields))
-
- (#TupleT ?members)
- (#TupleT (map (beta-reduce env) ?members))
-
- (#AppT [?type-fn ?type-arg])
- (#AppT [(beta-reduce env ?type-fn) (beta-reduce env ?type-arg)])
-
- (#AllT [?local-env ?local-name ?local-arg ?local-def])
- (case ?local-env
- #None
- (#AllT [(#Some env) ?local-name ?local-arg ?local-def])
-
- (#Some _)
- type)
-
- (#LambdaT [?input ?output])
- (#LambdaT [(beta-reduce env ?input) (beta-reduce env ?output)])
-
- (#BoundT ?name)
- (case (get ?name env)
- (#Some bound)
- bound
-
- _
- type)
-
- _
- type
- ))
-
-(defmacro #export (? tokens)
- (case tokens
- (\ (list maybe else))
- (do Lux/Monad
- [g!value (gensym "")]
- (return (list (` (case (~ maybe)
- (#;Some (~ g!value))
- (~ g!value)
-
- _
- (~ else))))))
-
- _
- (fail "Wrong syntax for ?")))
-
-(def (apply-type type-fn param)
- (-> Type Type (Maybe Type))
- (case type-fn
- (#AllT [env name arg body])
- (#Some (beta-reduce (|> (? env (list))
- (put name type-fn)
- (put arg param))
- body))
-
- (#AppT [F A])
- (do Maybe/Monad
- [type-fn* (apply-type F A)]
- (apply-type type-fn* param))
-
- _
- #None))
-
-(def (resolve-struct-type type)
- (-> Type (Maybe Type))
- (case type
- (#RecordT slots)
- (#Some type)
-
- (#AppT [fun arg])
- (apply-type fun arg)
-
- (#AllT [_ _ _ body])
- (resolve-struct-type body)
-
- _
- #None))
-
-(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)
- (-> Ident Compiler (Maybe Type))
- (let [vname' (ident->text name)]
- (case state
- {#source source #modules modules
- #envs envs #types types #host host
- #seed seed #eval? eval?}
- (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
- (lambda [env]
- (case env
- {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}}
- (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
- (lambda [binding]
- (let [[bname [_ type]] binding]
- (if (text:= vname' bname)
- (#Some type)
- #None)))))
- locals
- closure))))
- envs))))
-
-(def (show-envs envs)
- (-> (List (Env Text (, LuxVar Type))) Text)
- (|> envs
- (map (lambda [env]
- (case env
- {#name name #inner-closures _ #locals {#counter _ #mappings locals} #closure _}
- ($ text:++ name ": " (|> locals
- (map (: (All [a] (-> (, Text a) Text))
- (lambda [b] (let [[label _] b] label))))
- (interpose " ")
- (foldL text:++ ""))))))
- (interpose "\n")
- (foldL text:++ "")))
-
-(def (find-in-defs name state)
- (-> Ident Compiler (Maybe Type))
- (let [[v-prefix v-name] name
- {#source source #modules modules
- #envs envs #types types #host host
- #seed seed #eval? eval?} state]
- (case (get v-prefix modules)
- #None
- #None
-
- (#Some {#defs defs #module-aliases _ #imports _})
- (case (get v-name defs)
- #None
- #None
-
- (#Some [_ def-data])
- (case def-data
- #TypeD (#Some Type)
- (#ValueD type) (#Some type)
- (#MacroD m) (#Some Macro)
- (#AliasD name') (find-in-defs name' state))))))
-## (def (find-in-defs name state)
-## (-> Ident Compiler (Maybe Type))
-## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object]
-## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-defs #1: " (ident->text name) "\n")])
-## (let [[v-prefix v-name] name
-## {#source source #modules modules
-## #envs envs #types types #host host
-## #seed seed #eval? eval?} state]
-## (do Maybe/Monad
-## [module (get v-prefix modules)
-## #let [{#defs defs #module-aliases _ #imports _} module]
-## def (get v-name defs)
-## #let [[_ def-data] def]]
-## (case def-data
-## #TypeD (;return Type)
-## (#ValueD type) (;return type)
-## (#MacroD m) (;return Macro)
-## (#AliasD name') (find-in-defs name' state))))))
-
-(def (find-var-type name)
- (-> Ident (Lux Type))
- (do Lux/Monad
- [name' (normalize name)]
- (lambda [state]
- (case (find-in-env name state)
- (#Some struct-type)
- (#Right [state struct-type])
-
- _
- (case (find-in-defs name' state)
- (#Some struct-type)
- (#Right [state struct-type])
-
- _
- (let [{#source source #modules modules
- #envs envs #types types #host host
- #seed seed #eval? eval?} state]
- (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))))
-
-(defmacro #export (using tokens)
- (case tokens
- (\ (list struct body))
- (case struct
- (#Meta [_ (#SymbolS name)])
- (do Lux/Monad
- [struct-type (find-var-type name)]
- (case (resolve-struct-type struct-type)
- (#Some (#RecordT slots))
- (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax))
- (lambda [slot]
- (let [[sname stype] slot
- full-name (split-slot sname)]
- [(tag$ full-name) (symbol$ full-name)])))
- slots))]
- (return (list (` (_lux_case (~ struct) (~ pattern) (~ body))))))
-
- _
- (fail "Can only \"use\" records.")))
-
- _
- (let [dummy (symbol$ ["" ""])]
- (return (list (` (_lux_case (~ struct)
- (~ dummy)
- (using (~ dummy)
- (~ body))))))))
-
- _
- (fail "Wrong syntax for using")))
-
-(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 [xy]
- (let [[x y] xy]
- (f x y))))
-
-(defmacro #export (cond tokens)
- (if (i= 0 (i% (length tokens) 2))
- (fail "cond requires an even number of arguments.")
- (case (reverse tokens)
- (\ (list& else branches'))
- (return (list (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
- (lambda [else branch]
- (let [[right left] branch]
- (` (if (~ left) (~ right) (~ else))))))
- else
- (as-pairs branches'))))
-
- _
- (fail "Wrong syntax for cond"))))
-
-(defmacro #export (get@ tokens)
- (case tokens
- (\ (list (#Meta [_ (#TagS slot')]) record))
- (case record
- (#Meta [_ (#SymbolS name)])
- (do Lux/Monad
- [type (find-var-type name)
- g!blank (gensym "")
- g!output (gensym "")]
- (case (resolve-struct-type type)
- (#Some (#RecordT slots))
- (do Lux/Monad
- [slot (normalize slot')]
- (let [[s-prefix s-name] (: Ident slot)
- pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax))
- (lambda [slot]
- (let [[r-slot-name r-type] slot
- [r-prefix r-name] (split-slot r-slot-name)]
- [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix)
- (text:= s-name r-name))
- g!output
- g!blank)])))
- slots))]
- (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output)))))))
-
- _
- (fail "get@ can only use records.")))
-
- _
- (do Lux/Monad
- [_record (gensym "")]
- (return (list (` (let [(~ _record) (~ record)]
- (get@ (~ (tag$ slot')) (~ _record))))))))
-
- _
- (fail "Wrong syntax for get@")))
-
-(defmacro #export (open tokens)
- (case tokens
- (\ (list (#Meta [_ (#SymbolS struct-name)])))
- (do Lux/Monad
- [struct-type (find-var-type struct-name)]
- (case (resolve-struct-type struct-type)
- (#Some (#RecordT slots))
- (return (map (: (-> (, Text Type) Syntax)
- (lambda [slot]
- (let [[sname stype] slot
- [module name] (split-slot sname)]
- (` (_lux_def (~ (symbol$ ["" name]))
- (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name))))))))
- slots))
-
- _
- (fail "Can only \"open\" records.")))
-
- _
- (fail "Wrong syntax for open")))
-
-(def (foldL% M f x ys)
- (All [m a b]
- (-> (Monad m) (-> a b (m a)) a (List b)
- (m a)))
- (case ys
- (#Cons [y ys'])
- (do M
- [x' (f x y)]
- (foldL% M f x' ys'))
-
- #Nil
- ((get@ #return M) x)))
-
-(defmacro #export (:: tokens)
- (case tokens
- (\ (list& start parts))
- (do Lux/Monad
- [output (foldL% Lux/Monad
- (: (-> Syntax Syntax (Lux Syntax))
- (lambda [so-far part]
- (case part
- (#Meta [_ (#SymbolS slot)])
- (return (` (get@ (~ (tag$ slot)) (~ so-far))))
-
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))]))
- (return (` ((get@ (~ (tag$ slot)) (~ so-far))
- (~@ args))))
-
- _
- (fail "Wrong syntax for ::"))))
- start parts)]
- (return (list output)))
-
- _
- (fail "Wrong syntax for ::")))
-
-(defmacro #export (set@ tokens)
- (case tokens
- (\ (list (#Meta [_ (#TagS slot')]) value record))
- (case record
- (#Meta [_ (#SymbolS name)])
- (do Lux/Monad
- [type (find-var-type name)]
- (case (resolve-struct-type type)
- (#Some (#RecordT slots))
- (do Lux/Monad
- [pattern' (map% Lux/Monad
- (: (-> (, Text Type) (Lux (, Text Syntax)))
- (lambda [slot]
- (let [[r-slot-name r-type] slot]
- (do Lux/Monad
- [g!slot (gensym "")]
- (return [r-slot-name g!slot])))))
- slots)
- slot (normalize slot')]
- (let [[s-prefix s-name] (: Ident slot)
- pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
- (lambda [slot]
- (let [[r-slot-name r-var] slot]
- [(tag$ (split-slot r-slot-name)) r-var])))
- pattern'))
- output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
- (lambda [slot]
- (let [[r-slot-name r-var] slot
- [r-prefix r-name] (split-slot r-slot-name)]
- [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix)
- (text:= s-name r-name))
- value
- r-var)])))
- pattern'))]
- (return (list (` (_lux_case (~ record) (~ pattern) (~ output)))))))
-
- _
- (fail "set@ can only use records.")))
-
- _
- (do Lux/Monad
- [_record (gensym "")]
- (return (list (` (let [(~ _record) (~ record)]
- (set@ (~ (tag$ slot')) (~ value) (~ _record))))))))
-
- _
- (fail "Wrong syntax for set@")))
-
-(defmacro #export (update@ tokens)
- (case tokens
- (\ (list (#Meta [_ (#TagS slot')]) fun record))
- (case record
- (#Meta [_ (#SymbolS name)])
- (do Lux/Monad
- [type (find-var-type name)]
- (case (resolve-struct-type type)
- (#Some (#RecordT slots))
- (do Lux/Monad
- [pattern' (map% Lux/Monad
- (: (-> (, Text Type) (Lux (, Text Syntax)))
- (lambda [slot]
- (let [[r-slot-name r-type] slot]
- (do Lux/Monad
- [g!slot (gensym "")]
- (return [r-slot-name g!slot])))))
- slots)
- slot (normalize slot')]
- (let [[s-prefix s-name] (: Ident slot)
- pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
- (lambda [slot]
- (let [[r-slot-name r-var] slot]
- [(tag$ (split-slot r-slot-name)) r-var])))
- pattern'))
- output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
- (lambda [slot]
- (let [[r-slot-name r-var] slot
- [r-prefix r-name] (split-slot r-slot-name)]
- [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix)
- (text:= s-name r-name))
- (` ((~ fun) (~ r-var)))
- r-var)])))
- pattern'))]
- (return (list (` (_lux_case (~ record) (~ pattern) (~ output)))))))
-
- _
- (fail "update@ can only use records.")))
-
- _
- (do Lux/Monad
- [_record (gensym "")]
- (return (list (` (let [(~ _record) (~ record)]
- (update@ (~ (tag$ slot')) (~ fun) (~ _record))))))))
-
- _
- (fail "Wrong syntax for update@")))
-
-(defmacro #export (\template tokens)
- (case tokens
- (\ (list (#Meta [_ (#TupleS data)])
- (#Meta [_ (#TupleS bindings)])
- (#Meta [_ (#TupleS templates)])))
- (case (: (Maybe (List Syntax))
- (do Maybe/Monad
- [bindings' (map% Maybe/Monad get-ident bindings)
- data' (map% Maybe/Monad tuple->list data)]
- (let [apply (: (-> RepEnv (List Syntax))
- (lambda [env] (map (apply-template env) templates)))]
- (|> data'
- (join-map (. apply (make-env bindings')))
- ;return))))
- (#Some output)
- (return output)
-
- #None
- (fail "Wrong syntax for \\template"))
-
- _
- (fail "Wrong syntax for \\template")))
-
-(def #export complement
- (All [a] (-> (-> a Bool) (-> a Bool)))
- (. not))
-
-## (defmacro #export (loop tokens)
-## (case tokens
-## (\ (list bindings body))
-## (let [pairs (as-pairs bindings)
-## vars (map first pairs)
-## inits (map second pairs)]
-## (if (every? symbol? inits)
-## (do Lux/Monad
-## [inits' (map% Maybe/Monad get-ident inits)
-## init-types (map% Maybe/Monad find-var-type inits')]
-## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)]
-## (~ body))
-## (~@ inits))))))
-## (do Lux/Monad
-## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)]
-## (return (list (` (let [(~@ (interleave aliases inits))]
-## (loop [(~@ (interleave vars aliases))]
-## (~ body)))))))))
-
-## _
-## (fail "Wrong syntax for loop")))
diff --git a/input/lux/codata/stream.lux b/input/lux/codata/stream.lux
deleted file mode 100644
index 1d6dd1b50..000000000
--- a/input/lux/codata/stream.lux
+++ /dev/null
@@ -1,133 +0,0 @@
-## 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.
-
-(;import lux
- (lux (control (lazy #as L #refer #all)
- (functor #as F #refer #all)
- (monad #as M #refer #all)
- (comonad #as CM #refer #all))
- (meta lux
- macro
- syntax)
- (data (list #as l #refer (#only list list& List/Monad)))))
-
-## [Types]
-(deftype #export (Stream a)
- (Lazy (, a (Stream a))))
-
-## [Utils]
-(def (cycle' x xs init full)
- (All [a]
- (-> a (List a) a (List a) (Stream a)))
- (case xs
- #;Nil (cycle' init full init full)
- (#;Cons [y xs']) (... [x (cycle' y xs' init full)])))
-
-## [Functions]
-(def #export (iterate f x)
- (All [a]
- (-> (-> a a) a (Stream a)))
- (... [x (iterate f (f x))]))
-
-(def #export (repeat x)
- (All [a]
- (-> a (Stream a)))
- (... [x (repeat x)]))
-
-(def #export (cycle xs)
- (All [a]
- (-> (List a) (Maybe (Stream a))))
- (case xs
- #;Nil #;None
- (#;Cons [x xs']) (#;Some (cycle' x xs' x xs'))))
-
-(do-template [<name> <return> <part>]
- [(def #export (<name> s)
- (All [a] (-> (Stream a) <return>))
- (let [[h t] (! s)]
- <part>))]
-
- [head a h]
- [tail (Stream a) t])
-
-(def #export (@ idx s)
- (All [a] (-> Int (Stream a) a))
- (let [[h t] (! s)]
- (if (i> idx 0)
- (@ (dec idx) t)
- h)))
-
-(do-template [<taker> <dropper> <splitter> <det-type> <det-test> <det-step>]
- [(def #export (<taker> det xs)
- (All [a]
- (-> <det-type> (Stream a) (List a)))
- (let [[x xs'] (! xs)]
- (if <det-test>
- (list& x (<taker> <det-step> xs'))
- (list))))
-
- (def #export (<dropper> det xs)
- (All [a]
- (-> <det-type> (Stream a) (Stream a)))
- (let [[x xs'] (! xs)]
- (if <det-test>
- (<dropper> <det-step> xs')
- xs)))
-
- (def #export (<splitter> det xs)
- (All [a]
- (-> <det-type> (Stream a) (, (List a) (Stream a))))
- (let [[x xs'] (! xs)]
- (if <det-test>
- (let [[tail next] (<splitter> <det-step> xs')]
- [(#;Cons [x tail]) next])
- [(list) xs])))]
-
- [take-while drop-while split-with (-> a Bool) (det x) det]
- [take drop split Int (i> det 0) (dec det)]
- )
-
-(def #export (unfold step init)
- (All [a b]
- (-> (-> a (, a b)) a (Stream b)))
- (let [[next x] (step init)]
- (... [x (unfold step next)])))
-
-(def #export (filter p xs)
- (All [a] (-> (-> a Bool) (Stream a) (Stream a)))
- (let [[x xs'] (! xs)]
- (if (p x)
- (... [x (filter p xs')])
- (filter p xs'))))
-
-(def #export (partition p xs)
- (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a))))
- [(filter p xs) (filter (complement p) xs)])
-
-## [Structures]
-(defstruct #export Stream/Functor (Functor Stream)
- (def (F;map f fa)
- (let [[h t] (! fa)]
- (... [(f h) (F;map f t)]))))
-
-(defstruct #export Stream/CoMonad (CoMonad Stream)
- (def CM;_functor Stream/Functor)
- (def CM;unwrap head)
- (def (CM;split wa)
- (:: Stream/Functor (F;map repeat wa))))
-
-## [Pattern-matching]
-(defsyntax #export (\stream body [patterns' (+^ id^)])
- (do Lux/Monad
- [patterns (map% Lux/Monad macro-expand-1 patterns')
- g!s (gensym "s")
- #let [patterns+ (: (List Syntax)
- (do List/Monad
- [pattern (l;reverse patterns)]
- (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]]
- (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body)))))))
diff --git a/input/lux/control/comonad.lux b/input/lux/control/comonad.lux
deleted file mode 100644
index 1830ff44f..000000000
--- a/input/lux/control/comonad.lux
+++ /dev/null
@@ -1,54 +0,0 @@
-## 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.
-
-(;import lux
- (../functor #as F)
- lux/data/list
- lux/meta/macro)
-
-## Signatures
-(defsig #export (CoMonad w)
- (: (F;Functor w)
- _functor)
- (: (All [a]
- (-> (w a) a))
- unwrap)
- (: (All [a]
- (-> (w a) (w (w a))))
- split))
-
-## Functions
-(def #export (extend w f ma)
- (All [w a b]
- (-> (CoMonad w) (-> (w a) b) (w a) (w b)))
- (using w
- (using ;;_functor
- (F;map f (;;split ma)))))
-
-## Syntax
-(defmacro #export (be tokens state)
- (case tokens
- (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body))
- (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
- (lambda [body' binding]
- (let [[var value] binding]
- (case var
- (#;Meta [_ (#;TagS ["" "let"])])
- (` (;let (~ value) (~ body')))
-
- _
- (` (extend (;lambda [(~ var)] (~ body'))
- (~ value)))))))
- body
- (reverse (as-pairs bindings)))]
- (#;Right [state (list (` (;case (~ monad)
- {#;return ;return #;bind ;bind}
- (~ body'))))]))
-
- _
- (#;Left "Wrong syntax for be")))
diff --git a/input/lux/control/functor.lux b/input/lux/control/functor.lux
deleted file mode 100644
index 6a9dcfff8..000000000
--- a/input/lux/control/functor.lux
+++ /dev/null
@@ -1,15 +0,0 @@
-## 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.
-
-(;import lux)
-
-## Signatures
-(defsig #export (Functor f)
- (: (All [a b]
- (-> (-> a b) (f a) (f b)))
- map))
diff --git a/input/lux/control/lazy.lux b/input/lux/control/lazy.lux
deleted file mode 100644
index 22dac74fe..000000000
--- a/input/lux/control/lazy.lux
+++ /dev/null
@@ -1,47 +0,0 @@
-## 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.
-
-(;import lux
- (lux/meta macro)
- (.. (functor #as F #refer #all)
- (monad #as M #refer #all))
- (lux/data list))
-
-## Types
-(deftype #export (Lazy a)
- (All [b]
- (-> (-> a b) b)))
-
-## Syntax
-(defmacro #export (... tokens state)
- (case tokens
- (\ (list value))
- (let [blank (symbol$ ["" ""])]
- (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))]))
-
- _
- (#;Left "Wrong syntax for ...")))
-
-## Functions
-(def #export (! thunk)
- (All [a]
- (-> (Lazy a) a))
- (thunk id))
-
-## Structs
-(defstruct #export Lazy/Functor (Functor Lazy)
- (def (F;map f ma)
- (lambda [k] (ma (. k f)))))
-
-(defstruct #export Lazy/Monad (Monad Lazy)
- (def M;_functor Lazy/Functor)
-
- (def (M;wrap a)
- (... a))
-
- (def M;join !))
diff --git a/input/lux/control/monad.lux b/input/lux/control/monad.lux
deleted file mode 100644
index b5552f987..000000000
--- a/input/lux/control/monad.lux
+++ /dev/null
@@ -1,99 +0,0 @@
-## 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.
-
-(;import lux
- (.. (functor #as F)
- (monoid #as M))
- lux/meta/macro)
-
-## [Utils]
-(def (foldL f init xs)
- (All [a b]
- (-> (-> a b a) a (List b) a))
- (case xs
- #;Nil
- init
-
- (#;Cons [x xs'])
- (foldL f (f init x) xs')))
-
-(def (reverse xs)
- (All [a]
- (-> (List a) (List a)))
- (foldL (lambda [tail head] (#;Cons [head tail]))
- #;Nil
- xs))
-
-(def (as-pairs xs)
- (All [a] (-> (List a) (List (, a a))))
- (case xs
- (#;Cons [x1 (#;Cons [x2 xs'])])
- (#;Cons [[x1 x2] (as-pairs xs')])
-
- _
- #;Nil))
-
-## [Signatures]
-(defsig #export (Monad m)
- (: (F;Functor m)
- _functor)
- (: (All [a]
- (-> a (m a)))
- wrap)
- (: (All [a]
- (-> (m (m a)) (m a)))
- join))
-
-## [Syntax]
-(defmacro #export (do tokens state)
- (case tokens
- ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body))
- (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])])
- (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
- (lambda [body' binding]
- (let [[var value] binding]
- (case var
- (#;Meta [_ (#;TagS ["" "let"])])
- (` (;let (~ value) (~ body')))
-
- _
- (` (;case ;;_functor
- {#F;map F;map}
- (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join))))
- ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join)))
- ))))
- body
- (reverse (as-pairs bindings)))]
- (#;Right [state (#;Cons [(` (;case (~ monad)
- {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join}
- (~ body')))
- #;Nil])]))
-
- _
- (#;Left "Wrong syntax for do")))
-
-## [Functions]
-(def #export (bind m f ma)
- (All [m a b]
- (-> (Monad m) (-> a (m b)) (m a) (m b)))
- (using m
- (;;join (:: ;;_functor (F;map f ma)))))
-
-(def #export (map% m f xs)
- (All [m a b]
- (-> (Monad m) (-> a (m b)) (List a) (m (List b))))
- (case xs
- #;Nil
- (:: m (;;wrap #;Nil))
-
- (#;Cons [x xs'])
- (do m
- [y (f x)
- ys (map% m f xs')]
- (;;wrap (#;Cons [y ys])))
- ))
diff --git a/input/lux/control/monoid.lux b/input/lux/control/monoid.lux
deleted file mode 100644
index d32baabc5..000000000
--- a/input/lux/control/monoid.lux
+++ /dev/null
@@ -1,24 +0,0 @@
-## 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.
-
-(;import lux)
-
-## Signatures
-(defsig #export (Monoid a)
- (: a
- unit)
- (: (-> a a a)
- ++))
-
-## Constructors
-(def #export (monoid$ unit ++)
- (All [a]
- (-> a (-> a a a) (Monoid a)))
- (struct
- (def unit unit)
- (def ++ ++)))
diff --git a/input/lux/data/bool.lux b/input/lux/data/bool.lux
deleted file mode 100644
index d4f223612..000000000
--- a/input/lux/data/bool.lux
+++ /dev/null
@@ -1,33 +0,0 @@
-## 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.
-
-(;import lux
- (lux/control (monoid #as m))
- (.. (eq #as E)
- (show #as S)))
-
-## [Structures]
-(defstruct #export Bool/Eq (E;Eq Bool)
- (def (E;= x y)
- (if x
- y
- (not y))))
-
-(defstruct #export Bool/Show (S;Show Bool)
- (def (S;show x)
- (if x "true" "false")))
-
-(do-template [<name> <unit> <op>]
- [(defstruct #export <name> (m;Monoid Bool)
- (def m;unit <unit>)
- (def (m;++ x y)
- (<op> x y)))]
-
- [ Or/Monoid false or]
- [And/Monoid true and]
- )
diff --git a/input/lux/data/bounded.lux b/input/lux/data/bounded.lux
deleted file mode 100644
index 9d2dabde1..000000000
--- a/input/lux/data/bounded.lux
+++ /dev/null
@@ -1,17 +0,0 @@
-## 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.
-
-(;import lux)
-
-## Signatures
-(defsig #export (Bounded a)
- (: a
- top)
-
- (: a
- bottom))
diff --git a/input/lux/data/char.lux b/input/lux/data/char.lux
deleted file mode 100644
index 42e57509e..000000000
--- a/input/lux/data/char.lux
+++ /dev/null
@@ -1,20 +0,0 @@
-## 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.
-
-(;import lux
- (.. (eq #as E)
- (show #as S)))
-
-## [Structures]
-(defstruct #export Char/Eq (E;Eq Char)
- (def (E;= x y)
- (_jvm_ceq x y)))
-
-(defstruct #export Char/Show (S;Show Char)
- (def (S;show x)
- ($ text:++ "#\"" (_jvm_invokevirtual java.lang.Object toString [] x []) "\"")))
diff --git a/input/lux/data/dict.lux b/input/lux/data/dict.lux
deleted file mode 100644
index 63a66d49b..000000000
--- a/input/lux/data/dict.lux
+++ /dev/null
@@ -1,83 +0,0 @@
-## 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.
-
-(;import lux
- (lux/data (eq #as E)))
-
-## Signatures
-(defsig #export (Dict d)
- (: (All [k v]
- (-> k (d k v) (Maybe v)))
- get)
- (: (All [k v]
- (-> k v (d k v) (d k v)))
- put)
- (: (All [k v]
- (-> k (d k v) (d k v)))
- remove))
-
-## Types
-(deftype #export (PList k v)
- (| (#PList (, (E;Eq k) (List (, k v))))))
-
-## Constructors
-(def #export (plist eq)
- (All [k v]
- (-> (E;Eq k) (PList k v)))
- (#PList [eq #;Nil]))
-
-## Utils
-(def (pl-get eq k kvs)
- (All [k v]
- (-> (E;Eq k) k (List (, k v)) (Maybe v)))
- (case kvs
- #;Nil
- #;None
-
- (#;Cons [[k' v'] kvs'])
- (if (:: eq (E;= k k'))
- (#;Some v')
- (pl-get eq k kvs'))))
-
-(def (pl-put eq k v kvs)
- (All [k v]
- (-> (E;Eq k) k v (List (, k v)) (List (, k v))))
- (case kvs
- #;Nil
- (#;Cons [[k v] kvs])
-
- (#;Cons [[k' v'] kvs'])
- (if (:: eq (E;= k k'))
- (#;Cons [[k v] kvs'])
- (#;Cons [[k' v'] (pl-put eq k v kvs')]))))
-
-(def (pl-remove eq k kvs)
- (All [k v]
- (-> (E;Eq k) k (List (, k v)) (List (, k v))))
- (case kvs
- #;Nil
- kvs
-
- (#;Cons [[k' v'] kvs'])
- (if (:: eq (E;= k k'))
- kvs'
- (#;Cons [[k' v'] (pl-remove eq k kvs')]))))
-
-## Structs
-(defstruct #export PList/Dict (Dict PList)
- (def (get k plist)
- (let [(#PList [eq kvs]) plist]
- (pl-get eq k kvs)))
-
- (def (put k v plist)
- (let [(#PList [eq kvs]) plist]
- (#PList [eq (pl-put eq k v kvs)])))
-
- (def (remove k plist)
- (let [(#PList [eq kvs]) plist]
- (#PList [eq (pl-remove eq k kvs)]))))
diff --git a/input/lux/data/either.lux b/input/lux/data/either.lux
deleted file mode 100644
index 7166688b5..000000000
--- a/input/lux/data/either.lux
+++ /dev/null
@@ -1,46 +0,0 @@
-## 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.
-
-(;import lux
- (lux/data (list #refer (#except partition))))
-
-## [Types]
-## (deftype (Either l r)
-## (| (#;Left l)
-## (#;Right r)))
-
-## [Functions]
-(def #export (either f g e)
- (All [a b c] (-> (-> a c) (-> b c) (Either a b) c))
- (case e
- (#;Left x) (f x)
- (#;Right x) (g x)))
-
-(do-template [<name> <side> <tag>]
- [(def #export (<name> es)
- (All [a b] (-> (List (Either a b)) (List <side>)))
- (case es
- #;Nil #;Nil
- (#;Cons [(<tag> x) es']) (#;Cons [x (<name> es')])
- (#;Cons [_ es']) (<name> es')))]
-
- [lefts a #;Left]
- [rights b #;Right]
- )
-
-(def #export (partition es)
- (All [a b] (-> (List (Either a b)) (, (List a) (List b))))
- (foldL (: (All [a b]
- (-> (, (List a) (List b)) (Either a b) (, (List a) (List b))))
- (lambda [tails e]
- (let [[ltail rtail] tails]
- (case e
- (#;Left x) [(#;Cons [x ltail]) rtail]
- (#;Right x) [ltail (#;Cons [x rtail])]))))
- [(list) (list)]
- (reverse es)))
diff --git a/input/lux/data/eq.lux b/input/lux/data/eq.lux
deleted file mode 100644
index be3400208..000000000
--- a/input/lux/data/eq.lux
+++ /dev/null
@@ -1,14 +0,0 @@
-## 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.
-
-(;import lux)
-
-## [Signatures]
-(defsig #export (Eq a)
- (: (-> a a Bool)
- =))
diff --git a/input/lux/data/error.lux b/input/lux/data/error.lux
deleted file mode 100644
index cb5c309a6..000000000
--- a/input/lux/data/error.lux
+++ /dev/null
@@ -1,34 +0,0 @@
-## 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.
-
-(;import lux
- (lux/control (functor #as F #refer #all)
- (monad #as M #refer #all)))
-
-## [Types]
-(deftype #export (Error a)
- (| (#Fail Text)
- (#Ok a)))
-
-## [Structures]
-(defstruct #export Error/Functor (Functor Error)
- (def (F;map f ma)
- (case ma
- (#Fail msg) (#Fail msg)
- (#Ok datum) (#Ok (f datum)))))
-
-(defstruct #export Error/Monad (Monad Error)
- (def M;_functor Error/Functor)
-
- (def (M;wrap a)
- (#Ok a))
-
- (def (M;join mma)
- (case mma
- (#Fail msg) (#Fail msg)
- (#Ok ma) ma)))
diff --git a/input/lux/data/id.lux b/input/lux/data/id.lux
deleted file mode 100644
index 0e3bdbee6..000000000
--- a/input/lux/data/id.lux
+++ /dev/null
@@ -1,28 +0,0 @@
-## 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.
-
-(;import lux
- (lux/control (functor #as F #refer #all)
- (monad #as M #refer #all)))
-
-## [Types]
-(deftype #export (Id a)
- (| (#Id a)))
-
-## [Structures]
-(defstruct #export Id/Functor (Functor Id)
- (def (F;map f fa)
- (let [(#Id a) fa]
- (#Id (f a)))))
-
-(defstruct #export Id/Monad (Monad Id)
- (def M;_functor Id/Functor)
- (def (M;wrap a) (#Id a))
- (def (M;join mma)
- (let [(#Id ma) mma]
- ma)))
diff --git a/input/lux/data/io.lux b/input/lux/data/io.lux
deleted file mode 100644
index c08023df5..000000000
--- a/input/lux/data/io.lux
+++ /dev/null
@@ -1,51 +0,0 @@
-## 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.
-
-(;import lux
- (lux/meta macro)
- (lux/control (functor #as F)
- (monad #as M))
- lux/data/list)
-
-## Types
-(deftype #export (IO a)
- (-> (,) a))
-
-## Syntax
-(defmacro #export (io tokens state)
- (case tokens
- (\ (list value))
- (let [blank (symbol$ ["" ""])]
- (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))]))
-
- _
- (#;Left "Wrong syntax for io")))
-
-## Structures
-(defstruct #export IO/Functor (F;Functor IO)
- (def (F;map f ma)
- (io (f (ma [])))))
-
-(defstruct #export IO/Monad (M;Monad IO)
- (def M;_functor IO/Functor)
-
- (def (M;wrap x)
- (io x))
-
- (def (M;join mma)
- (mma [])))
-
-## Functions
-(def #export (print x)
- (-> Text (IO (,)))
- (io (_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")))
diff --git a/input/lux/data/list.lux b/input/lux/data/list.lux
deleted file mode 100644
index 450dee275..000000000
--- a/input/lux/data/list.lux
+++ /dev/null
@@ -1,250 +0,0 @@
-## 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.
-
-(;import lux
- (lux/control (monoid #as m #refer #all)
- (functor #as F #refer #all)
- (monad #as M #refer #all))
- lux/meta/macro)
-
-## Types
-## (deftype (List a)
-## (| #Nil
-## (#Cons (, a (List a)))))
-
-## Functions
-(def #export (foldL f init xs)
- (All [a b]
- (-> (-> a b a) a (List b) a))
- (case xs
- #;Nil
- init
-
- (#;Cons [x xs'])
- (foldL f (f init x) xs')))
-
-(def #export (foldR f init xs)
- (All [a b]
- (-> (-> b a a) a (List b) a))
- (case xs
- #;Nil
- init
-
- (#;Cons [x xs'])
- (f x (foldR f init xs'))))
-
-(def #export (reverse xs)
- (All [a]
- (-> (List a) (List a)))
- (foldL (lambda [tail head] (#;Cons [head tail]))
- #;Nil
- xs))
-
-(def #export (filter p xs)
- (All [a]
- (-> (-> a Bool) (List a) (List a)))
- (case xs
- #;Nil
- #;Nil
-
- (#;Cons [x xs'])
- (if (p x)
- (#;Cons [x (filter p xs')])
- (filter p xs'))))
-
-(def #export (partition p xs)
- (All [a] (-> (-> a Bool) (List a) (, (List a) (List a))))
- [(filter p xs) (filter (complement p) xs)])
-
-(def #export (as-pairs xs)
- (All [a] (-> (List a) (List (, a a))))
- (case xs
- (\ (#;Cons [x1 (#;Cons [x2 xs'])]))
- (#;Cons [[x1 x2] (as-pairs xs')])
-
- _
- #;Nil))
-
-(do-template [<name> <then> <else>]
- [(def #export (<name> n xs)
- (All [a]
- (-> Int (List a) (List a)))
- (if (i> n 0)
- (case xs
- #;Nil
- #;Nil
-
- (#;Cons [x xs'])
- <then>)
- <else>))]
-
- [take (#;Cons [x (take (dec n) xs')]) #;Nil]
- [drop (drop (dec n) xs') xs]
- )
-
-(do-template [<name> <then> <else>]
- [(def #export (<name> p xs)
- (All [a]
- (-> (-> a Bool) (List a) (List a)))
- (case xs
- #;Nil
- #;Nil
-
- (#;Cons [x xs'])
- (if (p x)
- <then>
- <else>)))]
-
- [take-while (#;Cons [x (take-while p xs')]) #;Nil]
- [drop-while (drop-while p xs') xs]
- )
-
-(def #export (split n xs)
- (All [a]
- (-> Int (List a) (, (List a) (List a))))
- (if (i> n 0)
- (case xs
- #;Nil
- [#;Nil #;Nil]
-
- (#;Cons [x xs'])
- (let [[tail rest] (split (dec n) xs')]
- [(#;Cons [x tail]) rest]))
- [#;Nil xs]))
-
-(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 (#;Cons [x ys]) xs')
- [ys xs])))
-
-(def #export (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 #export (repeat n x)
- (All [a]
- (-> Int a (List a)))
- (if (i> n 0)
- (#;Cons [x (repeat (dec n) x)])
- #;Nil))
-
-(def #export (iterate f x)
- (All [a]
- (-> (-> a (Maybe a)) a (List a)))
- (case (f x)
- (#;Some x')
- (#;Cons [x (iterate f x')])
-
- #;None
- (#;Cons [x #;Nil])))
-
-(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 #export (interpose sep xs)
- (All [a]
- (-> a (List a) (List a)))
- (case xs
- #;Nil
- xs
-
- (#;Cons [x #;Nil])
- xs
-
- (#;Cons [x xs'])
- (#;Cons [x (#;Cons [sep (interpose sep xs')])])))
-
-(def #export (size list)
- (-> List Int)
- (foldL (lambda [acc _] (i+ 1 acc)) 0 list))
-
-(do-template [<name> <init> <op>]
- [(def #export (<name> p xs)
- (All [a]
- (-> (-> a Bool) (List a) Bool))
- (foldL (lambda [_1 _2] (<op> _1 (p _2))) <init> xs))]
-
- [every? true and]
- [any? false or])
-
-(def #export (@ i xs)
- (All [a]
- (-> Int (List a) (Maybe a)))
- (case xs
- #;Nil
- #;None
-
- (#;Cons [x xs'])
- (if (i= 0 i)
- (#;Some x)
- (@ (dec i) xs'))))
-
-## Syntax
-(defmacro #export (list xs state)
- (#;Right [state (#;Cons [(foldL (lambda [tail head]
- (` (#;Cons [(~ head) (~ tail)])))
- (` #;Nil)
- (reverse xs))
- #;Nil])]))
-
-(defmacro #export (list& xs state)
- (case (reverse xs)
- (#;Cons [last init])
- (#;Right [state (list (foldL (lambda [tail head]
- (` (#;Cons [(~ head) (~ tail)])))
- last
- init))])
-
- _
- (#;Left "Wrong syntax for list&")))
-
-## Structures
-(defstruct #export List/Monoid (All [a]
- (Monoid (List a)))
- (def m;unit #;Nil)
- (def (m;++ xs ys)
- (case xs
- #;Nil ys
- (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)]))))
-
-(defstruct #export List/Functor (Functor List)
- (def (F;map f ma)
- (case ma
- #;Nil #;Nil
- (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')]))))
-
-(defstruct #export List/Monad (Monad List)
- (def M;_functor List/Functor)
-
- (def (M;wrap a)
- (#;Cons [a #;Nil]))
-
- (def (M;join mma)
- (using List/Monoid
- (foldL m;++ m;unit mma))))
diff --git a/input/lux/data/maybe.lux b/input/lux/data/maybe.lux
deleted file mode 100644
index faec53c2e..000000000
--- a/input/lux/data/maybe.lux
+++ /dev/null
@@ -1,42 +0,0 @@
-## 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.
-
-(;import lux
- (lux/control (monoid #as m #refer #all)
- (functor #as F #refer #all)
- (monad #as M #refer #all)))
-
-## [Types]
-## (deftype (Maybe a)
-## (| #;None
-## (#;Some a)))
-
-## [Structures]
-(defstruct #export Maybe/Monoid (Monoid Maybe)
- (def m;unit #;None)
- (def (m;++ xs ys)
- (case xs
- #;None ys
- (#;Some x) (#;Some x))))
-
-(defstruct #export Maybe/Functor (Functor Maybe)
- (def (F;map f ma)
- (case ma
- #;None #;None
- (#;Some a) (#;Some (f a)))))
-
-(defstruct #export Maybe/Monad (Monad Maybe)
- (def M;_functor Maybe/Functor)
-
- (def (M;wrap x)
- (#;Some x))
-
- (def (M;join mma)
- (case mma
- #;None #;None
- (#;Some xs) xs)))
diff --git a/input/lux/data/number.lux b/input/lux/data/number.lux
deleted file mode 100644
index 8da674d88..000000000
--- a/input/lux/data/number.lux
+++ /dev/null
@@ -1,119 +0,0 @@
-## 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.
-
-(;import lux
- (lux/control (monoid #as m))
- (lux/data (eq #as E)
- (ord #as O)
- (bounded #as B)
- (show #as S)))
-
-## Signatures
-(defsig #export (Number n)
- (do-template [<name>]
- [(: (-> n n n) <name>)]
- [+] [-] [*] [/] [%])
-
- (: (-> Int n)
- from-int)
-
- (do-template [<name>]
- [(: (-> n n) <name>)]
- [negate] [signum] [abs])
- )
-
-## [Structures]
-## Number
-(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>]
- [(defstruct #export <name> (Number <type>)
- (def + <+>)
- (def - <->)
- (def * <*>)
- (def / </>)
- (def % <%>)
- (def (from-int x)
- (<from> x))
- (def (negate x)
- (<*> <-1> x))
- (def (abs x)
- (if (<<> x <0>)
- (<*> <-1> x)
- x))
- (def (signum x)
- (cond (<=> x <0>) <0>
- (<<> x <0>) <-1>
- ## else
- <1>))
- )]
-
- [ Int/Number Int i+ i- i* i/ i% i= i< id 0 1 -1]
- [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0])
-
-## Eq
-(defstruct #export Int/Eq (E;Eq Int)
- (def E;= i=))
-
-(defstruct #export Real/Eq (E;Eq Real)
- (def E;= r=))
-
-## Ord
-## (def #export Int/Ord (O;Ord Int)
-## (O;ord$ Int/Eq i< i>))
-
-## (def #export Real/Ord (O;Ord Real)
-## (O;ord$ Real/Eq r< r>))
-
-(do-template [<name> <type> <eq> <lt> <gt>]
- [(defstruct #export <name> (O;Ord <type>)
- (def O;_eq <eq>)
- (def O;< <lt>)
- (def (O;<= x y)
- (or (<lt> x y)
- (using <eq> (E;= x y))))
- (def O;> <gt>)
- (def (O;>= x y)
- (or (<gt> x y)
- (using <eq> (E;= x y)))))]
-
- [ Int/Ord Int Int/Eq i< i>]
- [Real/Ord Real Real/Eq r< r>])
-
-## Bounded
-(do-template [<name> <type> <top> <bottom>]
- [(defstruct #export <name> (B;Bounded <type>)
- (def B;top <top>)
- (def B;bottom <bottom>))]
-
- [ Int/Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)]
- [Real/Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)])
-
-## Monoid
-(do-template [<name> <type> <unit> <++>]
- [(defstruct #export <name> (m;Monoid <type>)
- (def m;unit <unit>)
- (def m;++ <++>))]
-
- [ IntAdd/Monoid Int 0 i+]
- [ IntMul/Monoid Int 1 i*]
- [RealAdd/Monoid Real 0.0 r+]
- [RealMul/Monoid Real 1.0 r*]
- [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)]
- [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)]
- [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)]
- [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)]
- )
-
-## Show
-(do-template [<name> <type> <body>]
- [(defstruct #export <name> (S;Show <type>)
- (def (S;show x)
- <body>))]
-
- [ Int/Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])]
- [Real/Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])]
- )
diff --git a/input/lux/data/ord.lux b/input/lux/data/ord.lux
deleted file mode 100644
index 80f2e4fb5..000000000
--- a/input/lux/data/ord.lux
+++ /dev/null
@@ -1,44 +0,0 @@
-## 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.
-
-(;import lux
- (../eq #as E))
-
-## [Signatures]
-(defsig #export (Ord a)
- (: (E;Eq a)
- _eq)
- (do-template [<name>]
- [(: (-> a a Bool) <name>)]
-
- [<] [<=] [>] [>=]))
-
-## [Constructors]
-(def #export (ord$ eq < >)
- (All [a]
- (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a)))
- (struct
- (def _eq eq)
- (def < <)
- (def (<= x y)
- (or (< x y)
- (:: eq (E;= x y))))
- (def > >)
- (def (>= x y)
- (or (> x y)
- (:: eq (E;= x y))))))
-
-## [Functions]
-(do-template [<name> <op>]
- [(def #export (<name> ord x y)
- (All [a]
- (-> (Ord a) a a a))
- (if (:: ord (<op> x y)) x y))]
-
- [max ;;>]
- [min ;;<])
diff --git a/input/lux/data/reader.lux b/input/lux/data/reader.lux
deleted file mode 100644
index c3bbc2830..000000000
--- a/input/lux/data/reader.lux
+++ /dev/null
@@ -1,33 +0,0 @@
-## 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.
-
-(;import (lux #refer (#except Reader))
- (lux/control (functor #as F #refer #all)
- (monad #as M #refer #all)))
-
-## [Types]
-(deftype #export (Reader r a)
- (-> r a))
-
-## [Structures]
-(defstruct #export Reader/Functor (All [r]
- (Functor (Reader r)))
- (def (F;map f fa)
- (lambda [env]
- (f (fa env)))))
-
-(defstruct #export Reader/Monad (All [r]
- (Monad (Reader r)))
- (def M;_functor Reader/Functor)
-
- (def (M;wrap x)
- (lambda [env] x))
-
- (def (M;join mma)
- (lambda [env]
- (mma env env))))
diff --git a/input/lux/data/show.lux b/input/lux/data/show.lux
deleted file mode 100644
index f4e1cf762..000000000
--- a/input/lux/data/show.lux
+++ /dev/null
@@ -1,14 +0,0 @@
-## 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.
-
-(;import lux)
-
-## Signatures
-(defsig #export (Show a)
- (: (-> a Text)
- show))
diff --git a/input/lux/data/state.lux b/input/lux/data/state.lux
deleted file mode 100644
index bc9858a29..000000000
--- a/input/lux/data/state.lux
+++ /dev/null
@@ -1,35 +0,0 @@
-## 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.
-
-(;import lux
- (lux/control (functor #as F #refer #all)
- (monad #as M #refer #all)))
-
-## [Types]
-(deftype #export (State s a)
- (-> s (, s a)))
-
-## [Structures]
-(defstruct #export State/Functor (Functor State)
- (def (F;map f ma)
- (lambda [state]
- (let [[state' a] (ma state)]
- [state' (f a)]))))
-
-(defstruct #export State/Monad (All [s]
- (Monad (State s)))
- (def M;_functor State/Functor)
-
- (def (M;wrap x)
- (lambda [state]
- [state x]))
-
- (def (M;join mma)
- (lambda [state]
- (let [[state' ma] (mma state)]
- (ma state')))))
diff --git a/input/lux/data/text.lux b/input/lux/data/text.lux
deleted file mode 100644
index a3192a1d5..000000000
--- a/input/lux/data/text.lux
+++ /dev/null
@@ -1,146 +0,0 @@
-## 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.
-
-(;import lux
- (lux/control (monoid #as m))
- (lux/data (eq #as E)
- (ord #as O)
- (show #as S)))
-
-## [Functions]
-(def #export (size x)
- (-> Text Int)
- (_jvm_i2l (_jvm_invokevirtual java.lang.String length []
- x [])))
-
-(def #export (@ idx x)
- (-> Int Text (Maybe Char))
- (if (and (i< idx (size x))
- (i>= idx 0))
- (#;Some (_jvm_invokevirtual java.lang.String charAt [int]
- x [(_jvm_l2i idx)]))
- #;None))
-
-(def #export (contains? x y)
- (-> Text Text Bool)
- (_jvm_invokevirtual java.lang.String contains [java.lang.CharSequence]
- x [y]))
-
-(do-template [<name> <method>]
- [(def #export (<name> x)
- (-> Text Text)
- (_jvm_invokevirtual java.lang.String <method> []
- x []))]
- [lower-case toLowerCase]
- [upper-case toUpperCase]
- [trim trim]
- )
-
-(def #export (sub' from to x)
- (-> Int Int Text (Maybe Text))
- (if (and (i< from to)
- (i>= from 0)
- (i<= to (size x)))
- (_jvm_invokevirtual java.lang.String substring [int int]
- x [(_jvm_l2i from) (_jvm_l2i to)])
- #;None))
-
-(def #export (sub from x)
- (-> Int Text (Maybe Text))
- (sub' from (size x) x))
-
-(def #export (split at x)
- (-> Int Text (Maybe (, Text Text)))
- (if (and (i< at (size x))
- (i>= at 0))
- (let [pre (_jvm_invokevirtual java.lang.String substring [int int]
- x [(_jvm_l2i 0) (_jvm_l2i at)])
- post (_jvm_invokevirtual java.lang.String substring [int]
- x [(_jvm_l2i at)])]
- (#;Some [pre post]))
- #;None))
-
-(def #export (replace pattern value template)
- (-> Text Text Text Text)
- (_jvm_invokevirtual java.lang.String replace [java.lang.CharSequence java.lang.CharSequence]
- template [pattern value]))
-
-(do-template [<common> <general> <method>]
- [(def #export (<general> pattern from x)
- (-> Text Int Text (Maybe Int))
- (if (and (i< from (size x)) (i>= from 0))
- (case (_jvm_i2l (_jvm_invokevirtual java.lang.String <method> [java.lang.String int]
- x [pattern (_jvm_l2i from)]))
- -1 #;None
- idx (#;Some idx))
- #;None))
-
- (def #export (<common> pattern x)
- (-> Text Text (Maybe Int))
- (case (_jvm_i2l (_jvm_invokevirtual java.lang.String <method> [java.lang.String]
- x [pattern]))
- -1 #;None
- idx (#;Some idx)))]
-
- [index-of index-of' indexOf]
- [last-index-of last-index-of' lastIndexOf]
- )
-
-(def #export (starts-with? prefix x)
- (-> Text Text Bool)
- (case (index-of prefix x)
- (#;Some 0)
- true
-
- _
- false))
-
-(def #export (ends-with? postfix x)
- (-> Text Text Bool)
- (case (last-index-of postfix x)
- (#;Some n)
- (i= (i+ n (size postfix))
- (size x))
-
- _
- false))
-
-## [Structures]
-(defstruct #export Text/Eq (E;Eq Text)
- (def (E;= x y)
- (_jvm_invokevirtual java.lang.Object equals [java.lang.Object]
- x [y])))
-
-(defstruct #export Text/Ord (O;Ord Text)
- (def O;_eq Text/Eq)
- (def (O;< x y)
- (i< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String]
- x [y]))
- 0))
- (def (O;<= x y)
- (i<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String]
- x [y]))
- 0))
- (def (O;> x y)
- (i> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String]
- x [y]))
- 0))
- (def (O;>= x y)
- (i>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String]
- x [y]))
- 0)))
-
-(defstruct #export Text/Show (S;Show Text)
- (def (S;show x)
- x))
-
-(defstruct #export Text/Monoid (m;Monoid Text)
- (def m;unit "")
- (def (m;++ x y)
- (_jvm_invokevirtual java.lang.String concat [java.lang.String]
- x [y])))
diff --git a/input/lux/data/writer.lux b/input/lux/data/writer.lux
deleted file mode 100644
index f71492e35..000000000
--- a/input/lux/data/writer.lux
+++ /dev/null
@@ -1,34 +0,0 @@
-## 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.
-
-(;import lux
- (lux/control (monoid #as m #refer #all)
- (functor #as F #refer #all)
- (monad #as M #refer #all)))
-
-## [Types]
-(deftype #export (Writer l a)
- (, l a))
-
-## [Structures]
-(defstruct #export Writer/Functor (All [l]
- (Functor (Writer l)))
- (def (F;map f fa)
- (let [[log datum] fa]
- [log (f datum)])))
-
-(defstruct #export (Writer/Monad mon) (All [l]
- (-> (Monoid l) (Monad (Writer l))))
- (def M;_functor Writer/Functor)
-
- (def (M;wrap x)
- [(:: mon m;unit) x])
-
- (def (M;join mma)
- (let [[log1 [log2 a]] mma]
- [(:: mon (m;++ log1 log2)) a])))
diff --git a/input/lux/host/java.lux b/input/lux/host/java.lux
deleted file mode 100644
index 12525d3f2..000000000
--- a/input/lux/host/java.lux
+++ /dev/null
@@ -1,312 +0,0 @@
-## 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.
-
-(;import lux
- (lux (control (monoid #as m)
- (functor #as F)
- (monad #as M #refer (#only do)))
- (data list
- (text #as text))
- (meta lux
- macro
- syntax)))
-
-## (open List/Functor)
-
-## [Utils/Parsers]
-(def finally^
- (Parser Syntax)
- (form^ (do Parser/Monad
- [_ (symbol?^ ["" "finally"])
- expr id^
- _ end^]
- (M;wrap expr))))
-
-(def catch^
- (Parser (, Text Ident Syntax))
- (form^ (do Parser/Monad
- [_ (symbol?^ ["" "catch"])
- ex-class local-symbol^
- ex symbol^
- expr id^
- _ end^]
- (M;wrap [ex-class ex expr]))))
-
-(def method-decl^
- (Parser (, (List Text) Text (List Text) Text))
- (form^ (do Parser/Monad
- [modifiers (*^ local-tag^)
- name local-symbol^
- inputs (tuple^ (*^ local-symbol^))
- output local-symbol^
- _ end^]
- (M;wrap [modifiers name inputs output]))))
-
-(def field-decl^
- (Parser (, (List Text) Text Text))
- (form^ (do Parser/Monad
- [modifiers (*^ local-tag^)
- name local-symbol^
- class local-symbol^
- _ end^]
- (M;wrap [modifiers name class]))))
-
-(def arg-decl^
- (Parser (, Text Text))
- (form^ (do Parser/Monad
- [arg-name local-symbol^
- arg-class local-symbol^
- _ end^]
- (M;wrap [arg-name arg-class]))))
-
-(def method-def^
- (Parser (, (List Text) Text (List (, Text Text)) Text Syntax))
- (form^ (do Parser/Monad
- [modifiers (*^ local-tag^)
- name local-symbol^
- inputs (tuple^ (*^ arg-decl^))
- output local-symbol^
- body id^
- _ end^]
- (M;wrap [modifiers name inputs output body]))))
-
-(def method-call^
- (Parser (, Text (List Text) (List Syntax)))
- (form^ (do Parser/Monad
- [method local-symbol^
- arity-classes (tuple^ (*^ local-symbol^))
- arity-args (tuple^ (*^ id^))
- _ end^
- _ (: (Parser (,))
- (if (i= (size arity-classes)
- (size arity-args))
- (M;wrap [])
- (lambda [_] #;None)))]
- (M;wrap [method arity-classes arity-args])
- )))
-
-## [Utils/Lux]
-## (def (find-class-field field class)
-## (-> Text Text (Lux Type))
-## ...)
-
-## (def (find-virtual-method method class)
-## (-> Text Text (Lux (List (, (List Type) Type))))
-## ...)
-
-## (def (find-static-method method class)
-## (-> Text Text (Lux (List (, (List Type) Type))))
-## ...)
-
-
-## [Syntax]
-(defsyntax #export (throw ex)
- (emit (list (` (_jvm_throw (~ ex))))))
-
-(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)])
- (emit (list (` (_jvm_try (~ body)
- (~@ (list:++ (:: List/Functor (F;map (: (-> (, Text Ident Syntax) Syntax)
- (lambda [catch]
- (let [[class ex body] catch]
- (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body))))))
- catches))
- (case finally
- #;None
- (list)
-
- (#;Some finally)
- (list (` (_jvm_finally (~ finally))))))))))))
-
-(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)])
- (do Lux/Monad
- [current-module get-module-name
- #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module)
- name))]]
- (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax)
- (lambda [member]
- (let [[modifiers name inputs output] member]
- (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))])))))
- members))]
- (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))]
- (~@ members'))))))))
-
-(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))]
- [fields (*^ field-decl^)]
- [methods (*^ method-def^)])
- (do Lux/Monad
- [current-module get-module-name
- #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module)
- name))
- fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax)
- (lambda [field]
- (let [[modifiers name class] field]
- (` ((~ (symbol$ ["" name]))
- (~ (text$ class))
- [(~@ (:: List/Functor (F;map text$ modifiers)))])))))
- fields))
- methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax)
- (lambda [methods]
- (let [[modifiers name inputs output body] methods]
- (` ((~ (symbol$ ["" name]))
- [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax)
- (lambda [in]
- (let [[left right] in]
- (form$ (list (text$ left)
- (text$ right))))))
- inputs)))]
- (~ (text$ output))
- [(~@ (:: List/Functor (F;map text$ modifiers)))]
- (~ body))))))
- methods))]]
- (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super))
- [(~@ (:: List/Functor (F;map text$ interfaces)))]
- [(~@ fields')]
- [(~@ methods')]))))))
-
-(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))])
- (emit (list (` (_jvm_new (~ (text$ class))
- [(~@ (:: List/Functor (F;map text$ arg-classes)))]
- [(~@ args)])))))
-
-(defsyntax #export (instance? [class local-symbol^] obj)
- (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj))))))
-
-(defsyntax #export (locking lock body)
- (do Lux/Monad
- [g!lock (gensym "")
- g!body (gensym "")]
- (emit (list (` (;let [(~ g!lock) (~ lock)
- _ (_jvm_monitor-enter (~ g!lock))
- (~ g!body) (~ body)
- _ (_jvm_monitor-exit (~ g!lock))]
- (~ g!body)))))
- ))
-
-(defsyntax #export (null? obj)
- (emit (list (` (_jvm_null? (~ obj))))))
-
-(defsyntax #export (program [args symbol^] body)
- (emit (list (` (_jvm_program (~ (symbol$ args))
- (~ body))))))
-
-## (defsyntax #export (.? [field local-symbol^] obj)
-## (case obj
-## (#;Meta [_ (#;SymbolS obj-name)])
-## (do Lux/Monad
-## [obj-type (find-var-type obj-name)]
-## (case obj-type
-## (#;DataT class)
-## (do Lux/Monad
-## [field-class (find-field field class)]
-## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class))))
-
-## _
-## (fail "Can only get field from object.")))
-
-## _
-## (do Lux/Monad
-## [g!obj (gensym "")]
-## (emit (list (` (;let [(~ g!obj) (~ obj)]
-## (.? (~ field) (~ g!obj)))))))))
-
-## (defsyntax #export (.= [field local-symbol^] value obj)
-## (case obj
-## (#;Meta [_ (#;SymbolS obj-name)])
-## (do Lux/Monad
-## [obj-type (find-var-type obj-name)]
-## (case obj-type
-## (#;DataT class)
-## (do Lux/Monad
-## [field-class (find-field field class)]
-## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value)))
-
-## _
-## (fail "Can only set field of object.")))
-
-## _
-## (do Lux/Monad
-## [g!obj (gensym "")]
-## (emit (list (` (;let [(~ g!obj) (~ obj)]
-## (.= (~ field) (~ value) (~ g!obj)))))))))
-
-## (defsyntax #export (.! [call method-call^] obj)
-## (case obj
-## (#;Meta [_ (#;SymbolS obj-name)])
-## (do Lux/Monad
-## [obj-type (find-var-type obj-name)]
-## (case obj-type
-## (#;DataT class)
-## (do Lux/Monad
-## [#let [[m-name ?m-classes m-args] call]
-## all-m-details (find-virtual-method m-name class)
-## m-ins (case [?m-classes all-m-details]
-## (\ [#;None (list [m-ins m-out])])
-## (M;wrap m-ins)
-
-## (\ [(#;Some m-ins) _])
-## (M;wrap m-ins)
-
-## _
-## #;None)]
-## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))]
-## (~ obj) [(~@ m-args)])))))
-
-## _
-## (fail "Can only call method on object.")))
-
-## _
-## (do Lux/Monad
-## [g!obj (gensym "")]
-## (emit (list (` (;let [(~ g!obj) (~ obj)]
-## (.! (~@ *tokens*)))))))))
-
-## (defsyntax #export (..? [field local-symbol^] [class local-symbol^])
-## (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field)))))))
-
-## (defsyntax #export (..= [field local-symbol^] value [class local-symbol^])
-## (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value))))))
-
-## (defsyntax #export (..! [call method-call^] [class local-symbol^])
-## (do Lux/Monad
-## [#let [[m-name ?m-classes m-args] call]
-## all-m-details (find-static-method m-name class)
-## m-ins (case [?m-classes all-m-details]
-## (\ [#;None (list [m-ins m-out])])
-## (M;wrap m-ins)
-
-## (\ [(#;Some m-ins) _])
-## (M;wrap m-ins)
-
-## _
-## #;None)]
-## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class))
-## [(~@ (:: List/Functor (F;map text$ m-ins)))]
-## [(~@ m-args)]))))
-## ))
-
-## (definterface Function []
-## (#public #abstract apply [java.lang.Object] java.lang.Object))
-
-## (_jvm_interface "Function" []
-## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"]))
-
-## (defclass MyFunction [Function]
-## (#public #static foo java.lang.Object)
-## (#public <init> [] void
-## (_jvm_invokespecial java.lang.Object <init> [] this []))
-## (#public apply [(arg java.lang.Object)] java.lang.Object
-## "YOLO"))
-
-## (_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"))
diff --git a/input/lux/math.lux b/input/lux/math.lux
deleted file mode 100644
index 2e29c5da7..000000000
--- a/input/lux/math.lux
+++ /dev/null
@@ -1,60 +0,0 @@
-## 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.
-
-(;import lux)
-
-## [Constants]
-(do-template [<name> <value>]
- [(def #export <name>
- Real
- (_jvm_getstatic java.lang.Math <value>))]
-
- [e E]
- [pi PI]
- )
-
-## [Functions]
-(do-template [<name> <method>]
- [(def #export (<name> n)
- (-> Real Real)
- (_jvm_invokestatic java.lang.Math <method> [double] [n]))]
-
- [cos cos]
- [sin sin]
- [tan tan]
-
- [acos acos]
- [asin asin]
- [atan atan]
-
- [cosh cosh]
- [sinh sinh]
- [tanh tanh]
-
- [ceil ceil]
- [floor floor]
- [round round]
-
- [exp exp]
- [log log]
-
- [cbrt cbrt]
- [sqrt sqrt]
-
- [->degrees toDegrees]
- [->radians toRadians]
- )
-
-(do-template [<name> <method>]
- [(def #export (<name> x y)
- (-> Real Real Real)
- (_jvm_invokestatic java.lang.Math <method> [double double] [x y]))]
-
- [atan2 atan2]
- [pow pow]
- )
diff --git a/input/lux/meta/lux.lux b/input/lux/meta/lux.lux
deleted file mode 100644
index a28d6e5d4..000000000
--- a/input/lux/meta/lux.lux
+++ /dev/null
@@ -1,287 +0,0 @@
-## 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.
-
-(;import lux
- (.. macro)
- (lux/control (monoid #as m)
- (functor #as F)
- (monad #as M #refer (#only do)))
- (lux/data list
- maybe
- (show #as S)
- (number #as N)))
-
-## [Types]
-## (deftype (Lux a)
-## (-> Compiler (Either Text (, Compiler a))))
-
-## [Utils]
-(def (ident->text ident)
- (-> Ident Text)
- (let [[pre post] ident]
- ($ text:++ pre ";" post)))
-
-## [Structures]
-(defstruct #export Lux/Functor (F;Functor Lux)
- (def (F;map f fa)
- (lambda [state]
- (case (fa state)
- (#;Left msg)
- (#;Left msg)
-
- (#;Right [state' a])
- (#;Right [state' (f a)])))))
-
-(defstruct #export Lux/Monad (M;Monad Lux)
- (def M;_functor Lux/Functor)
- (def (M;wrap x)
- (lambda [state]
- (#;Right [state x])))
- (def (M;join mma)
- (lambda [state]
- (case (mma state)
- (#;Left msg)
- (#;Left msg)
-
- (#;Right [state' ma])
- (ma state')))))
-
-## Functions
-(def #export (get-module-name state)
- (Lux Text)
- (case (reverse (get@ #;envs state))
- #;Nil
- (#;Left "Can't get the module name without a module!")
-
- (#;Cons [env _])
- (#;Right [state (get@ #;name env)])))
-
-(def (get k plist)
- (All [a]
- (-> Text (List (, Text a)) (Maybe a)))
- (case plist
- #;Nil
- #;None
-
- (#;Cons [[k' v] plist'])
- (if (text:= k k')
- (#;Some v)
- (get k plist'))))
-
-(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 (|> (: (Module Compiler) $module) (get@ #;defs) (get name))]
- (case (: (, Bool (DefData' Macro)) gdef)
- [exported? (#;MacroD macro')]
- (if (or exported? (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]
- (: (Lux (Maybe Macro))
- (lambda [state]
- (#;Right [state (find-macro' (get@ #;modules state) current-module module name)]))))))
-
-(def #export (normalize ident)
- (-> Ident (Lux Ident))
- (case ident
- ["" name]
- (do Lux/Monad
- [module-name get-module-name]
- (M;wrap (: Ident [module-name name])))
-
- _
- (:: Lux/Monad (M;wrap ident))))
-
-(def #export (macro-expand syntax)
- (-> Syntax (Lux (List Syntax)))
- (case syntax
- (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))])
- (do Lux/Monad
- [macro-name' (normalize macro-name)
- ?macro (find-macro macro-name')]
- (case ?macro
- (#;Some macro)
- (do Lux/Monad
- [expansion (macro args)
- expansion' (M;map% Lux/Monad macro-expand expansion)]
- (M;wrap (:: List/Monad (M;join expansion'))))
-
- #;None
- (do Lux/Monad
- [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))]
- (M;wrap (list (form$ (:: List/Monad (M;join parts'))))))))
-
- (#;Meta [_ (#;FormS (#;Cons [harg targs]))])
- (do Lux/Monad
- [harg+ (macro-expand harg)
- targs+ (M;map% Lux/Monad macro-expand targs)]
- (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+))))))))
-
- (#;Meta [_ (#;TupleS members)])
- (do Lux/Monad
- [members' (M;map% Lux/Monad macro-expand members)]
- (M;wrap (list (tuple$ (:: List/Monad (M;join members'))))))
-
- _
- (:: Lux/Monad (M;wrap (list syntax)))))
-
-(def #export (gensym prefix state)
- (-> Text (Lux Syntax))
- (#;Right [(update@ #;seed inc state)
- (symbol$ ["__gensym__" (:: N;Int/Show (S;show (get@ #;seed state)))])]))
-
-(def #export (emit datum)
- (All [a]
- (-> a (Lux a)))
- (lambda [state]
- (#;Right [state datum])))
-
-(def #export (fail msg)
- (All [a]
- (-> Text (Lux a)))
- (lambda [_]
- (#;Left msg)))
-
-(def #export (macro-expand-1 token)
- (-> Syntax (Lux Syntax))
- (do Lux/Monad
- [token+ (macro-expand token)]
- (case token+
- (\ (list token'))
- (M;wrap token')
-
- _
- (fail "Macro expanded to more than 1 element."))))
-
-(def #export (module-exists? module state)
- (-> Text (Lux Bool))
- (#;Right [state (case (get module (get@ #;modules state))
- (#;Some _)
- true
-
- #;None
- false)]))
-
-(def #export (exported-defs module state)
- (-> Text (Lux (List Text)))
- (case (get module (get@ #;modules state))
- (#;Some =module)
- (using List/Monad
- (#;Right [state (M;join (:: M;_functor (F;map (: (-> (, Text (, Bool (DefData' Macro)))
- (List Text))
- (lambda [gdef]
- (let [[name [export? _]] gdef]
- (if export?
- (list name)
- (list)))))
- (get@ #;defs =module))))]))
-
- #;None
- (#;Left ($ text:++ "Unknown module: " module))))
-
-(def (show-envs envs)
- (-> (List (Env Text (, LuxVar Type))) Text)
- (|> envs
- (F;map (lambda [env]
- (case env
- {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _}
- ($ text:++ name ": " (|> locals
- (F;map (: (All [a] (-> (, Text a) Text))
- (lambda [b] (let [[label _] b] label))))
- (:: List/Functor)
- (interpose " ")
- (foldL text:++ ""))))))
- (:: List/Functor)
- (interpose "\n")
- (foldL text:++ "")))
-
-(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)
- (-> Ident Compiler (Maybe Type))
- (let [vname' (ident->text name)]
- (case state
- {#;source source #;modules modules
- #;envs envs #;types types #;host host
- #;seed seed #;eval? eval?}
- (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
- (lambda [env]
- (case env
- {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}}
- (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
- (lambda [binding]
- (let [[bname [_ type]] binding]
- (if (text:= vname' bname)
- (#;Some type)
- #;None)))))
- locals
- closure))))
- envs))))
-
-(def (find-in-defs name state)
- (-> Ident Compiler (Maybe Type))
- (let [[v-prefix v-name] name
- {#;source source #;modules modules
- #;envs envs #;types types #;host host
- #;seed seed #;eval? eval?} state]
- (case (get v-prefix modules)
- #;None
- #;None
-
- (#;Some {#;defs defs #;module-aliases _ #;imports _})
- (case (get v-name defs)
- #;None
- #;None
-
- (#;Some [_ def-data])
- (case def-data
- #;TypeD (#;Some Type)
- (#;ValueD type) (#;Some type)
- (#;MacroD m) (#;Some Macro)
- (#;AliasD name') (find-in-defs name' state))))))
-
-(def #export (find-var-type name)
- (-> Ident (Lux Type))
- (do Lux/Monad
- [name' (normalize name)]
- (: (Lux Type)
- (lambda [state]
- (case (find-in-env name state)
- (#;Some struct-type)
- (#;Right [state struct-type])
-
- _
- (case (find-in-defs name' state)
- (#;Some struct-type)
- (#;Right [state struct-type])
-
- _
- (let [{#;source source #;modules modules
- #;envs envs #;types types #;host host
- #;seed seed #;eval? eval?} state]
- (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))
- ))
diff --git a/input/lux/meta/macro.lux b/input/lux/meta/macro.lux
deleted file mode 100644
index 22aeaf874..000000000
--- a/input/lux/meta/macro.lux
+++ /dev/null
@@ -1,54 +0,0 @@
-## 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.
-
-(;import lux)
-
-## [Utils]
-(def (_meta x)
- (-> (Syntax' (Meta Cursor)) Syntax)
- (#;Meta [["" -1 -1] x]))
-
-## [Syntax]
-(def #export (defmacro tokens state)
- Macro
- (case tokens
- (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])
- (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args))
- (~ (_meta (#;SymbolS ["lux" "Macro"])))
- (~ body)))
- (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name)))
- #;Nil])])])
-
- (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])])
- (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args))
- (~ (_meta (#;SymbolS ["lux" "Macro"])))
- (~ body)))
- (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name)))
- #;Nil])])])
-
- _
- (#;Left "Wrong syntax for defmacro")))
-(_lux_declare-macro defmacro)
-
-## [Functions]
-(do-template [<name> <type> <tag>]
- [(def #export (<name> x)
- (-> <type> Syntax)
- (#;Meta [["" -1 -1] (<tag> x)]))]
-
- [bool$ Bool #;BoolS]
- [int$ Int #;IntS]
- [real$ Real #;RealS]
- [char$ Char #;CharS]
- [text$ Text #;TextS]
- [symbol$ Ident #;SymbolS]
- [tag$ Ident #;TagS]
- [form$ (List Syntax) #;FormS]
- [tuple$ (List Syntax) #;TupleS]
- [record$ (List (, Syntax Syntax)) #;RecordS]
- )
diff --git a/input/lux/meta/syntax.lux b/input/lux/meta/syntax.lux
deleted file mode 100644
index 1fe85c32f..000000000
--- a/input/lux/meta/syntax.lux
+++ /dev/null
@@ -1,262 +0,0 @@
-## 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.
-
-(;import lux
- (.. (macro #as m #refer #all)
- (lux #as l #refer (#only Lux/Monad gensym)))
- (lux (control (functor #as F)
- (monad #as M #refer (#only do)))
- (data (eq #as E)
- (bool #as b)
- (char #as c)
- (text #as t)
- list)))
-
-## [Utils]
-(def (first xy)
- (All [a b] (-> (, a b) a))
- (let [[x y] xy]
- x))
-
-(def (join-pairs pairs)
- (All [a] (-> (List (, a a)) (List a)))
- (case pairs
- #;Nil #;Nil
- (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs'))))
-
-## Types
-(deftype #export (Parser a)
- (-> (List Syntax) (Maybe (, (List Syntax) a))))
-
-## Structures
-(defstruct #export Parser/Functor (F;Functor Parser)
- (def (F;map f ma)
- (lambda [tokens]
- (case (ma tokens)
- #;None
- #;None
-
- (#;Some [tokens' a])
- (#;Some [tokens' (f a)])))))
-
-(defstruct #export Parser/Monad (M;Monad Parser)
- (def M;_functor Parser/Functor)
-
- (def (M;wrap x tokens)
- (#;Some [tokens x]))
-
- (def (M;join mma)
- (lambda [tokens]
- (case (mma tokens)
- #;None
- #;None
-
- (#;Some [tokens' ma])
- (ma tokens')))))
-
-## Parsers
-(def #export (id^ tokens)
- (Parser Syntax)
- (case tokens
- #;Nil #;None
- (#;Cons [t tokens']) (#;Some [tokens' t])))
-
-(do-template [<name> <type> <tag>]
- [(def #export (<name> tokens)
- (Parser <type>)
- (case tokens
- (#;Cons [(#;Meta [_ (<tag> x)]) tokens'])
- (#;Some [tokens' x])
-
- _
- #;None))]
-
- [ bool^ Bool #;BoolS]
- [ int^ Int #;IntS]
- [ real^ Real #;RealS]
- [ char^ Char #;CharS]
- [ text^ Text #;TextS]
- [symbol^ Ident #;SymbolS]
- [ tag^ Ident #;TagS]
- )
-
-(do-template [<name> <tag>]
- [(def #export (<name> tokens)
- (Parser Text)
- (case tokens
- (#;Cons [(#;Meta [_ (<tag> ["" x])]) tokens'])
- (#;Some [tokens' x])
-
- _
- #;None))]
-
- [local-symbol^ #;SymbolS]
- [ local-tag^ #;TagS]
- )
-
-(def (ident:= x y)
- (-> Ident Ident Bool)
- (let [[x1 x2] x
- [y1 y2] y]
- (and (text:= x1 y1)
- (text:= x2 y2))))
-
-(do-template [<name> <type> <tag> <eq>]
- [(def #export (<name> v tokens)
- (-> <type> (Parser (,)))
- (case tokens
- (#;Cons [(#;Meta [_ (<tag> x)]) tokens'])
- (if (<eq> v x)
- (#;Some [tokens' []])
- #;None)
-
- _
- #;None))]
-
- [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)]
- [ int?^ Int #;IntS i=]
- [ real?^ Real #;RealS r=]
- [ char?^ Char #;CharS (:: c;Char/Eq E;=)]
- [ text?^ Text #;TextS (:: t;Text/Eq E;=)]
- [symbol?^ Ident #;SymbolS ident:=]
- [ tag?^ Ident #;TagS ident:=]
- )
-
-(do-template [<name> <tag>]
- [(def #export (<name> p tokens)
- (All [a]
- (-> (Parser a) (Parser a)))
- (case tokens
- (#;Cons [(#;Meta [_ (<tag> form)]) tokens'])
- (case (p form)
- (#;Some [#;Nil x]) (#;Some [tokens' x])
- _ #;None)
-
- _
- #;None))]
-
- [ form^ #;FormS]
- [tuple^ #;TupleS]
- )
-
-(def #export (?^ p tokens)
- (All [a]
- (-> (Parser a) (Parser (Maybe a))))
- (case (p tokens)
- #;None (#;Some [tokens #;None])
- (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)])))
-
-(def (run-parser p tokens)
- (All [a]
- (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a))))
- (p tokens))
-
-(def #export (*^ p tokens)
- (All [a]
- (-> (Parser a) (Parser (List a))))
- (case (p tokens)
- #;None (#;Some [tokens (list)])
- (#;Some [tokens' x]) (run-parser (do Parser/Monad
- [xs (*^ p)]
- (M;wrap (list& x xs)))
- tokens')))
-
-(def #export (+^ p)
- (All [a]
- (-> (Parser a) (Parser (List a))))
- (do Parser/Monad
- [x p
- xs (*^ p)]
- (M;wrap (list& x xs))))
-
-(def #export (&^ p1 p2)
- (All [a b]
- (-> (Parser a) (Parser b) (Parser (, a b))))
- (do Parser/Monad
- [x1 p1
- x2 p2]
- (M;wrap [x1 x2])))
-
-(def #export (|^ p1 p2 tokens)
- (All [a b]
- (-> (Parser a) (Parser b) (Parser (Either b))))
- (case (p1 tokens)
- (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)])
- #;None (run-parser (do Parser/Monad
- [x2 p2]
- (M;wrap (#;Right x2)))
- tokens)))
-
-(def #export (||^ ps tokens)
- (All [a]
- (-> (List (Parser a)) (Parser (Maybe a))))
- (case ps
- #;Nil #;None
- (#;Cons [p ps']) (case (p tokens)
- #;None (||^ ps' tokens)
- (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)]))
- ))
-
-(def #export (end^ tokens)
- (Parser (,))
- (case tokens
- #;Nil (#;Some [tokens []])
- _ #;None))
-
-## Syntax
-(defmacro #export (defsyntax tokens)
- (let [[exported? tokens] (: (, Bool (List Syntax))
- (case tokens
- (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens'))
- [true tokens']
-
- _
- [false tokens]))]
- (case tokens
- (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))])
- body))
- (do Lux/Monad
- [names+parsers (M;map% Lux/Monad
- (: (-> Syntax (Lux (, Syntax Syntax)))
- (lambda [arg]
- (case arg
- (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)])
- parser))]))
- (M;wrap [(symbol$ var-name) parser])
-
- (\ (#;Meta [_ (#;SymbolS var-name)]))
- (M;wrap [(symbol$ var-name) (` id^)])
-
- _
- (l;fail "Syntax pattern expects 2-tuples or symbols."))))
- args)
- g!tokens (gensym "tokens")
- g!_ (gensym "_")
- #let [names (:: List/Functor (F;map first names+parsers))
- error-msg (text$ (text:++ "Wrong syntax for " name))
- body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
- (lambda [body name+parser]
- (let [[name parser] name+parser]
- (` (_lux_case ((~ parser) (~ g!tokens))
- (#;Some [(~ g!tokens) (~ name)])
- (~ body)
-
- (~ g!_)
- (l;fail (~ error-msg)))))))
- body
- (reverse names+parsers))
- macro-def (: Syntax
- (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens))
- (~ body'))))]]
- (M;wrap (list& macro-def
- (if exported?
- (list (` (_lux_export (~ (symbol$ ["" name])))))
- (list)))))
-
- _
- (l;fail "Wrong syntax for defsyntax"))))
diff --git a/input/program.lux b/input/program.lux
deleted file mode 100644
index 984d8610f..000000000
--- a/input/program.lux
+++ /dev/null
@@ -1,48 +0,0 @@
-## 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.
-
-(;import lux
- (lux (codata (stream #as S))
- (control monoid
- functor
- monad
- lazy
- comonad)
- (data bool
- bounded
- char
- ## cont
- dict
- (either #as e)
- eq
- error
- id
- io
- list
- maybe
- number
- ord
- (reader #as r)
- show
- state
- (text #as t)
- writer)
- (host java)
- (meta lux
- macro
- syntax)
- math
- ))
-
-(program args
- (case args
- #;Nil
- (println "Hello, world!")
-
- (#;Cons [name _])
- (println ($ text:++ "Hello, " name "!"))))
diff --git a/source/lux.lux b/source/lux.lux
new file mode 100644
index 000000000..50f8f1af2
--- /dev/null
+++ b/source/lux.lux
@@ -0,0 +1,2784 @@
+## 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"]))
+
+## 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 Unit (#TupleT #Nil))
+(_lux_export Unit)
+
+(_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])]))])]))
+(_lux_export Bindings)
+
+## (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])])])]))])]))
+(_lux_export Env)
+
+## (deftype Cursor
+## (, Text Int Int))
+(_lux_def Cursor
+ (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])])))
+(_lux_export Cursor)
+
+## (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])])])]))]))
+(_lux_export DefData')
+
+## (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
+## #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;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 _cursor
+## Cursor
+## ["" -1 -1])
+(_lux_def _cursor
+ (_lux_: Cursor ["" -1 -1]))
+
+## (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 [_cursor 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 (#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 (#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 (#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 (#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 (#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 (#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 (#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' (defmacro tokens)
+ Macro
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])
+ (return (#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 (#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 #Nil))
+
+(defmacro (->' tokens)
+ (_lux_case tokens
+ (#Cons [input (#Cons [output #Nil])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"]))
+ (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])])))
+ #Nil])])))
+ #Nil]))
+
+ (#Cons [input (#Cons [output others])])
+ (return (#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 (#Cons [body
+ #Nil]))
+
+ (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))])
+ (#Cons [body #Nil])])
+ (return (#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 (#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 (#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' (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' (reverse list)
+ (All' [a]
+ (->' ($' List (B' a)) ($' List (B' a))))
+ (foldL (lambda' [tail head] (#Cons [head tail]))
+ #Nil
+ list))
+
+(defmacro (list xs)
+ (return (#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 (list& xs)
+ (_lux_case (reverse xs)
+ (#Cons [last init])
+ (return (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 (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 (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 (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 (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 (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 (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax))
+ Syntax)
+ (lambda [body binding]
+ (_lux_case binding
+ [label value]
+ (form$ (list (symbol$ ["" "_lux_case"]) value label body)))))
+ body
+ (reverse (as-pairs bindings)))))
+
+ _
+ (fail "Wrong syntax for let")))
+
+(def'' (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'' (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'' #export (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 (list (foldL (lambda [a1 a2] (form$ (list op a1 a2)))
+ init
+ args)))
+
+ _
+ (fail "Wrong syntax for $")))
+
+(def'' (splice replace? untemplate tag elems)
+ (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
+ (_lux_case replace?
+ true
+ (_lux_case (any? spliced? elems)
+ true
+ (let [elems' (map (lambda [elem]
+ (_lux_case elem
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))])
+ spliced
+
+ _
+ (form$ (list (symbol$ ["" "_lux_:"])
+ (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"])))))
+ (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem)
+ (tag$ ["lux" "Nil"])))))))))
+ 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))))))
+ false
+ (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))))
+
+(def'' (untemplate replace? subst token)
+ (->' Bool Text Syntax Syntax)
+ (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? 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 replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems)
+
+ [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])]
+ unquoted
+
+ [_ (#Meta [_ (#FormS elems)])]
+ (splice replace? (untemplate replace? 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 replace? subst k) (untemplate replace? subst v))))))
+ fields)))))
+ ))
+
+(defmacro (`' tokens)
+ (_lux_case tokens
+ (#Cons [template #Nil])
+ (return (list (untemplate true "" template)))
+
+ _
+ (fail "Wrong syntax for `'")))
+
+(defmacro (' tokens)
+ (_lux_case tokens
+ (#Cons [template #Nil])
+ (return (list (untemplate false "" template)))
+
+ _
+ (fail "Wrong syntax for '")))
+
+(defmacro #export (|> tokens)
+ (_lux_case tokens
+ (#Cons [init apps])
+ (return (list (foldL (lambda [acc app]
+ (_lux_case app
+ (#Meta [_ (#TupleS parts)])
+ (tuple$ (list:++ parts (list acc)))
+
+ (#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 (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 (list (`' (#;DataT (~ (_meta (#TextS class-name)))))))
+
+ _
+ (fail "Wrong syntax for ^")))
+
+(defmacro #export (-> tokens)
+ (_lux_case (reverse tokens)
+ (#Cons [output inputs])
+ (return (list (foldL (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))
+ output
+ inputs)))
+
+ _
+ (fail "Wrong syntax for ->")))
+
+(defmacro #export (, tokens)
+ (return (list (`' (#;TupleT (~ (untemplate-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 (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 #Nil)
+
+ (#Cons [x xs'])
+ (do m
+ [y (f x)
+ ys (map% m f xs')]
+ (;return (#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'' #export (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 "Wrong syntax for do-template"))
+
+ _
+ (fail "Wrong syntax for do-template")))
+
+(do-template [<name> <cmp> <type>]
+ [(def'' #export (<name> x y)
+ (-> <type> <type> Bool)
+ (<cmp> x y))]
+
+ [i= _jvm_leq Int]
+ [i> _jvm_lgt Int]
+ [i< _jvm_llt Int]
+ [r= _jvm_deq Real]
+ [r> _jvm_dgt Real]
+ [r< _jvm_dlt Real]
+ )
+
+(do-template [<name> <cmp> <eq> <type>]
+ [(def'' #export (<name> x y)
+ (-> <type> <type> Bool)
+ (if (<cmp> x y)
+ true
+ (<eq> x y)))]
+
+ [i>= i> i= Int]
+ [i<= i< i= Int]
+ [r>= r> r= Real]
+ [r<= r< r= Real]
+ )
+
+(do-template [<name> <cmp> <type>]
+ [(def'' #export (<name> x y)
+ (-> <type> <type> <type>)
+ (<cmp> x y))]
+
+ [i+ _jvm_ladd Int]
+ [i- _jvm_lsub Int]
+ [i* _jvm_lmul Int]
+ [i/ _jvm_ldiv Int]
+ [i% _jvm_lrem Int]
+ [r+ _jvm_dadd Real]
+ [r- _jvm_dsub Real]
+ [r* _jvm_dmul Real]
+ [r/ _jvm_ddiv Real]
+ [r% _jvm_drem Real]
+ )
+
+(def'' (multiple? div n)
+ (-> Int Int Bool)
+ (i= 0 (i% n div)))
+
+(def'' (length list)
+ (-> List Int)
+ (foldL (lambda [acc _] (i+ 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 (list body))
+
+ (#Cons [harg targs])
+ (let [replacements (map (_lux_: (-> Text (, Text Syntax))
+ (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))]))
+ (list& self-ident idents))
+ body' (foldL (lambda [body' arg']
+ (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')])))
+ (replace-syntax replacements body)
+ (reverse targs))]
+ ## (#;Some #;Nil)
+ (return (list (`' (#;AllT [#;None (~ (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'' (put k v dict)
+ (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'' (get-module-name state)
+ ($' Lux Text)
+ (_lux_case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #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'' (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 #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'' (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 (`' [(~ (text$ (ident->text ident))) (;,)])))
+
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))])
+ (do Lux/Monad
+ [ident (normalize ident)]
+ (;return (`' [(~ (text$ (ident->text ident))) (~ value)])))
+
+ _
+ (fail "Wrong syntax for |"))))
+ tokens)]
+ (;return (list (`' (#;VariantT (~ (untemplate-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 (`' [(~ (text$ (ident->text ident))) (~ value)])))
+
+ _
+ (fail "Wrong syntax for &"))))
+ (as-pairs tokens))]
+ (;return (list (`' (#;RecordT (~ (untemplate-list pairs)))))))))
+
+(def'' #export (->text x)
+ (-> (^ java.lang.Object) Text)
+ (_jvm_invokevirtual java.lang.Object toString [] x []))
+
+(def'' (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'' (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 macro-name')]
+ (_lux_case ?macro
+ (#Some macro)
+ (do Lux/Monad
+ [expansion (macro args)
+ expansion' (map% Lux/Monad macro-expand expansion)]
+ (;return (list:join expansion')))
+
+ #None
+ (do Lux/Monad
+ [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))]
+ (;return (list (form$ (list:join parts')))))))
+
+ (#Meta [_ (#FormS (#Cons [harg targs]))])
+ (do Lux/Monad
+ [harg+ (macro-expand harg)
+ targs+ (map% Lux/Monad macro-expand targs)]
+ (;return (list (form$ (list:++ harg+ (list:join targs+))))))
+
+ (#Meta [_ (#TupleS members)])
+ (do Lux/Monad
+ [members' (map% Lux/Monad macro-expand members)]
+ (;return (list (tuple$ (list:join members')))))
+
+ _
+ (return (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 (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 type+
+ (#Cons [type' #Nil])
+ (;return (list (walk-type type')))
+
+ _
+ (fail "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 (list (`' (_lux_: (;type (~ type)) (~ value)))))
+
+ _
+ (fail "Wrong syntax for :")))
+
+(defmacro #export (:! tokens)
+ (_lux_case tokens
+ (#Cons [type (#Cons [value #Nil])])
+ (return (list (`' (_lux_:! (;type (~ type)) (~ value)))))
+
+ _
+ (fail "Wrong syntax for :!")))
+
+(def'' (empty? xs)
+ (All [a] (-> ($' List a) Bool))
+ (_lux_case xs
+ #Nil true
+ _ false))
+
+(defmacro #export (deftype tokens)
+ (let [[export? tokens'] (: (, Bool (List Syntax))
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
+ [true tokens']
+
+ _
+ [false tokens]))
+ [rec? tokens'] (: (, Bool (List Syntax))
+ (_lux_case tokens'
+ (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens'])
+ [true tokens']
+
+ _
+ [false tokens']))
+ parts (: (Maybe (, Text (List Syntax) Syntax))
+ (_lux_case tokens'
+ (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])])
+ (#Some [name #Nil type])
+
+ (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])])
+ (#Some [name args type])
+
+ _
+ #None))]
+ (_lux_case parts
+ (#Some [name args type])
+ (let [with-export (: (List Syntax)
+ (if export?
+ (list (`' (_lux_export (~ (symbol$ ["" name])))))
+ #Nil))
+ type' (: (Maybe Syntax)
+ (if rec?
+ (if (empty? args)
+ (let [g!param (symbol$ ["" ""])
+ prime-name (symbol$ ["" (text:++ name "'")])
+ type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)]
+ (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+))
+ ;Void))))
+ #None)
+ (_lux_case args
+ #Nil
+ (#Some type)
+
+ _
+ (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))]
+ (_lux_case type'
+ (#Some type'')
+ (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type''))))
+ with-export))
+
+ #None
+ (fail "Wrong syntax for deftype")))
+
+ #None
+ (fail "Wrong syntax for deftype"))
+ ))
+## (defmacro #export (deftype tokens)
+## (let [[export? tokens'] (: (, Bool (List Syntax))
+## (_lux_case (:! (List Syntax) tokens)
+## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
+## [true (:! (List Syntax) tokens')]
+
+## _
+## [false (:! (List Syntax) 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& (`' (_lux_def (~ name) (;type (~ type'))))
+## with-export)))
+
+## #None
+## (fail "Wrong syntax for deftype"))
+## ))
+
+(defmacro #export (exec tokens)
+ (_lux_case (reverse tokens)
+ (#Cons [value actions])
+ (let [dummy (symbol$ ["" ""])]
+ (return (list (foldL (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& (`' (_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 expansion))]
+ (;return (list:join expansions)))
+
+ _
+ (;return (list branch))))))
+ (as-pairs branches))]
+ (;return (list (`' (_lux_case (~ value)
+ (~@ (|> 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 pattern+
+ (#Cons [pattern' #Nil])
+ (;return (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:join (map (lambda [pattern] (list pattern body))
+ (list:join patterns'))))))
+
+ _
+ (fail "Wrong syntax for \\or")))
+
+(do-template [<name> <offset>]
+ [(def #export <name> (i+ <offset>))]
+
+ [inc 1]
+ [dec -1])
+
+(defmacro #export (` tokens)
+ (do Lux/Monad
+ [module-name get-module-name]
+ (case tokens
+ (\ (list template))
+ (;return (list (untemplate true module-name template)))
+
+ _
+ (fail "Wrong syntax for `"))))
+
+(def (gensym prefix state)
+ (-> Text (Lux Syntax))
+ (case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval?}
+ (#Right [{#source source #modules modules
+ #envs envs #types types #host host
+ #seed (inc seed) #eval? eval?}
+ (symbol$ ["__gensym__" (->text seed)])])))
+
+(def (macro-expand-1 token)
+ (-> Syntax (Lux Syntax))
+ (do Lux/Monad
+ [token+ (macro-expand token)]
+ (case 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 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!"))))
+ (list:join tokens'))]
+ (;return (list (`' (#;RecordT (~ (untemplate-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& (`' (_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 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!"))))
+ (list:join tokens'))]
+ (;return (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& (`' (def (~ name) (~ type) (~ defs')))
+ (if export?
+ (list (`' (_lux_export (~ name))))
+ #Nil))))
+
+ #None
+ (fail "Wrong syntax for defstruct"))))
+
+(def #export (id x)
+ (All [a] (-> a a))
+ x)
+
+(do-template [<name> <form> <message>]
+ [(defmacro #export (<name> tokens)
+ (case (reverse tokens)
+ (\ (list& last init))
+ (return (list (foldL (lambda [post pre] (` <form>))
+ last
+ init)))
+
+ _
+ (fail <message>)))]
+
+ [and (if (~ pre) (~ post) false) "and requires >=1 clauses."]
+ [or (if (~ pre) true (~ post)) "or requires >=1 clauses."])
+
+(deftype Referrals
+ (| #All
+ (#Only (List Text))
+ (#Exclude (List Text))
+ #Nothing))
+
+(deftype Import
+ (, Text (Maybe Text) Referrals))
+
+(def (extract-defs defs)
+ (-> (List Syntax) (Lux (List Text)))
+ (map% Lux/Monad
+ (: (-> Syntax (Lux Text))
+ (lambda [def]
+ (case def
+ (#Meta [_ (#SymbolS ["" name])])
+ (return name)
+
+ _
+ (fail "only/exclude requires symbols."))))
+ defs))
+
+(def (parse-alias tokens)
+ (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax))))
+ (case tokens
+ (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens'))
+ (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens']))
+
+ _
+ (return (: (, (Maybe Text) (List Syntax)) [#None tokens]))))
+
+(def (parse-referrals tokens)
+ (-> (List Syntax) (Lux (, Referrals (List Syntax))))
+ (case tokens
+ (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens'))
+ (case referral
+ (#Meta [_ (#TagS ["" "all"])])
+ (return (: (, Referrals (List Syntax)) [#All tokens']))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))]))
+ (do Lux/Monad
+ [defs' (extract-defs defs)]
+ (return (: (, Referrals (List Syntax)) [(#Only defs') tokens'])))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "exclude"])]) defs))]))
+ (do Lux/Monad
+ [defs' (extract-defs defs)]
+ (return (: (, Referrals (List Syntax)) [(#Exclude defs') tokens'])))
+
+ _
+ (fail "Incorrect syntax for referral."))
+
+ _
+ (return (: (, Referrals (List Syntax)) [#Nothing tokens]))))
+
+(def (decorate-imports super-name tokens)
+ (-> Text (List Syntax) (Lux (List Syntax)))
+ (map% Lux/Monad
+ (: (-> Syntax (Lux Syntax))
+ (lambda [token]
+ (case token
+ (#Meta [_ (#SymbolS ["" sub-name])])
+ (return (symbol$ ["" ($ text:++ super-name "/" sub-name)]))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))]))
+ (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts)))
+
+ _
+ (fail "Wrong import syntax."))))
+ tokens))
+
+(def (parse-imports imports)
+ (-> (List Syntax) (Lux (List Import)))
+ (do Lux/Monad
+ [referrals' (map% Lux/Monad
+ (: (-> Syntax (Lux (List Import)))
+ (lambda [token]
+ (case token
+ (#Meta [_ (#SymbolS ["" m-name])])
+ (;return (list [m-name #None #All]))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))]))
+ (do Lux/Monad
+ [alias+extra' (parse-alias extra)
+ #let [[alias extra'] (: (, (Maybe Text) (List Syntax))
+ alias+extra')]
+ referral+extra'' (parse-referrals extra')
+ #let [[referral extra''] (: (, Referrals (List Syntax))
+ referral+extra'')]
+ extra''' (decorate-imports m-name extra'')
+ sub-imports (parse-imports extra''')]
+ (;return (case referral
+ #Nothing (case alias
+ #None sub-imports
+ (#Some _) (list& [m-name alias referral] sub-imports))
+ _ (list& [m-name alias referral] sub-imports))))
+
+ _
+ (fail "Wrong syntax for import"))))
+ imports)]
+ (;return (list:join referrals'))))
+
+(def (module-exists? module state)
+ (-> Text (Lux Bool))
+ (case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval?}
+ (case (get module modules)
+ (#Some =module)
+ (#Right [state true])
+
+ #None
+ (#Right [state false]))
+ ))
+
+(def (exported-defs module state)
+ (-> Text (Lux (List Text)))
+ (case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval?}
+ (case (get module modules)
+ (#Some =module)
+ (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))
+ (List Text))
+ (lambda [gdef]
+ (let [[name [export? _]] gdef]
+ (if export?
+ (list name)
+ (list)))))
+ (let [{#module-aliases _ #defs defs #imports _} =module]
+ defs))]
+ (#Right [state (list:join to-alias)]))
+
+ #None
+ (#Left ($ text:++ "Unknown module: " module)))
+ ))
+
+(def (last-index-of part text)
+ (-> Text Text Int)
+ (_jvm_i2l (_jvm_invokevirtual java.lang.String lastIndexOf [java.lang.String]
+ text [part])))
+
+(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-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)
+ (#Cons [module #Nil])
+ (#Cons [(substring2 0 idx module)
+ (split-module (substring1 (inc idx) module))]))))
+
+(def (@ idx xs)
+ (All [a]
+ (-> Int (List a) (Maybe a)))
+ (case xs
+ #Nil
+ #None
+
+ (#Cons [x xs'])
+ (if (i= idx 0)
+ (#Some x)
+ (@ (dec idx) xs')
+ )))
+
+(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 (clean-module module)
+ (-> Text (Lux Text))
+ (do Lux/Monad
+ [module-name get-module-name]
+ (case (split-module module)
+ (\ (list& "." parts))
+ (return (|> (list& module-name parts) (interpose "/") (foldL text:++ "")))
+
+ parts
+ (let [[ups parts'] (split-with (text:= "..") parts)
+ num-ups (length ups)]
+ (if (i= num-ups 0)
+ (return module)
+ (case (@ num-ups (split-module-contexts module-name))
+ #None
+ (fail (text:++ "Can't clean module: " module))
+
+ (#Some top-module)
+ (return (|> (list& top-module parts') (interpose "/") (foldL text:++ ""))))
+ )))
+ ))
+
+(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 (foldL (lambda [prev case]
+ (or prev
+ (text:= case name)))
+ false
+ cases)]
+ output))
+
+(defmacro #export (import tokens)
+ (do Lux/Monad
+ [imports (parse-imports tokens)
+ imports (map% Lux/Monad
+ (: (-> Import (Lux Import))
+ (lambda [import]
+ (case import
+ [m-name m-alias m-referrals]
+ (do Lux/Monad
+ [m-name (clean-module m-name)]
+ (;return (: Import [m-name m-alias m-referrals]))))))
+ imports)
+ unknowns' (map% Lux/Monad
+ (: (-> Import (Lux (List Text)))
+ (lambda [import]
+ (case import
+ [m-name _ _]
+ (do Lux/Monad
+ [? (module-exists? m-name)]
+ (;return (if ?
+ (list)
+ (list m-name)))))))
+ imports)
+ #let [unknowns (list:join unknowns')]]
+ (case unknowns
+ #Nil
+ (do Lux/Monad
+ [output' (map% Lux/Monad
+ (: (-> Import (Lux (List Syntax)))
+ (lambda [import]
+ (case import
+ [m-name m-alias m-referrals]
+ (do Lux/Monad
+ [defs (case m-referrals
+ #All
+ (exported-defs m-name)
+
+ (#Only +defs)
+ (do Lux/Monad
+ [*defs (exported-defs m-name)]
+ (;return (filter (is-member? +defs) *defs)))
+
+ (#Exclude -defs)
+ (do Lux/Monad
+ [*defs (exported-defs m-name)]
+ (;return (filter (. not (is-member? -defs)) *defs)))
+
+ #Nothing
+ (;return (list)))]
+ (;return ($ list:++
+ (list (` (_lux_import (~ (text$ m-name)))))
+ (case m-alias
+ #None (list)
+ (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))
+ (map (: (-> Text Syntax)
+ (lambda [def]
+ (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def]))))))
+ defs)))))))
+ imports)]
+ (;return (list:join output')))
+
+ _
+ (;return (: (List Syntax)
+ (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name)))))
+ unknowns)
+ (list (` (import (~@ tokens))))))))))
+
+(def (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 (split-slot slot)
+ (-> Text (, Text Text))
+ (let [idx (index-of ";" slot)
+ module (substring2 0 idx slot)
+ name (substring1 (inc idx) slot)]
+ [module name]))
+
+(def (type:show type)
+ (-> Type Text)
+ (case type
+ (#DataT name)
+ ($ text:++ "(^ " name ")")
+
+ (#TupleT elems)
+ (case elems
+ #;Nil
+ "(,)"
+
+ _
+ ($ text:++ "(, " (|> elems (map type:show) (interpose " ") (foldL text:++ "")) ")"))
+
+ (#VariantT cases)
+ (case cases
+ #;Nil
+ "(|)"
+
+ _
+ ($ text:++ "(| "
+ (|> cases
+ (map (: (-> (, Text Type) Text)
+ (lambda [kv]
+ (case kv
+ [k (#TupleT #;Nil)]
+ ($ text:++ "#" k)
+
+ [k v]
+ ($ text:++ "(#" k " " (type:show v) ")")))))
+ (interpose " ")
+ (foldL text:++ ""))
+ ")"))
+
+ (#RecordT fields)
+ (case fields
+ #;Nil
+ "(&)"
+
+ _
+ ($ text:++ "(& "
+ (|> fields
+ (map (: (-> (, Text Type) Text)
+ (: (-> (, Text Type) Text)
+ (lambda [kv]
+ (let [[k v] kv]
+ ($ text:++ "(#" k " " (type:show v) ")"))))))
+ (interpose " ")
+ (foldL text:++ ""))
+ ")"))
+
+ (#LambdaT [input output])
+ ($ text:++ "(-> " (type:show input) " " (type:show output) ")")
+
+ (#VarT id)
+ ($ text:++ "⌈" (->text id) "⌋")
+
+ (#BoundT name)
+ name
+
+ (#ExT ?id)
+ ($ text:++ "⟨" (->text ?id) "⟩")
+
+ (#AppT [?lambda ?param])
+ ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")")
+
+ (#AllT [?env ?name ?arg ?body])
+ ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")")
+ ))
+
+(def (beta-reduce env type)
+ (-> (List (, Text Type)) Type Type)
+ (case type
+ (#VariantT ?cases)
+ (#VariantT (map (: (-> (, Text Type) (, Text Type))
+ (lambda [kv]
+ (let [[k v] kv]
+ [k (beta-reduce env v)])))
+ ?cases))
+
+ (#RecordT ?fields)
+ (#RecordT (map (: (-> (, Text Type) (, Text Type))
+ (lambda [kv]
+ (let [[k v] kv]
+ [k (beta-reduce env v)])))
+ ?fields))
+
+ (#TupleT ?members)
+ (#TupleT (map (beta-reduce env) ?members))
+
+ (#AppT [?type-fn ?type-arg])
+ (#AppT [(beta-reduce env ?type-fn) (beta-reduce env ?type-arg)])
+
+ (#AllT [?local-env ?local-name ?local-arg ?local-def])
+ (case ?local-env
+ #None
+ (#AllT [(#Some env) ?local-name ?local-arg ?local-def])
+
+ (#Some _)
+ type)
+
+ (#LambdaT [?input ?output])
+ (#LambdaT [(beta-reduce env ?input) (beta-reduce env ?output)])
+
+ (#BoundT ?name)
+ (case (get ?name env)
+ (#Some bound)
+ bound
+
+ _
+ type)
+
+ _
+ type
+ ))
+
+(defmacro #export (? tokens)
+ (case tokens
+ (\ (list maybe else))
+ (do Lux/Monad
+ [g!value (gensym "")]
+ (return (list (` (case (~ maybe)
+ (#;Some (~ g!value))
+ (~ g!value)
+
+ _
+ (~ else))))))
+
+ _
+ (fail "Wrong syntax for ?")))
+
+(def (apply-type type-fn param)
+ (-> Type Type (Maybe Type))
+ (case type-fn
+ (#AllT [env name arg body])
+ (#Some (beta-reduce (|> (? env (list))
+ (put name type-fn)
+ (put arg param))
+ body))
+
+ (#AppT [F A])
+ (do Maybe/Monad
+ [type-fn* (apply-type F A)]
+ (apply-type type-fn* param))
+
+ _
+ #None))
+
+(def (resolve-struct-type type)
+ (-> Type (Maybe Type))
+ (case type
+ (#RecordT slots)
+ (#Some type)
+
+ (#AppT [fun arg])
+ (apply-type fun arg)
+
+ (#AllT [_ _ _ body])
+ (resolve-struct-type body)
+
+ _
+ #None))
+
+(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)
+ (-> Ident Compiler (Maybe Type))
+ (let [vname' (ident->text name)]
+ (case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval?}
+ (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
+ (lambda [env]
+ (case env
+ {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}}
+ (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
+ (lambda [binding]
+ (let [[bname [_ type]] binding]
+ (if (text:= vname' bname)
+ (#Some type)
+ #None)))))
+ locals
+ closure))))
+ envs))))
+
+(def (show-envs envs)
+ (-> (List (Env Text (, LuxVar Type))) Text)
+ (|> envs
+ (map (lambda [env]
+ (case env
+ {#name name #inner-closures _ #locals {#counter _ #mappings locals} #closure _}
+ ($ text:++ name ": " (|> locals
+ (map (: (All [a] (-> (, Text a) Text))
+ (lambda [b] (let [[label _] b] label))))
+ (interpose " ")
+ (foldL text:++ ""))))))
+ (interpose "\n")
+ (foldL text:++ "")))
+
+(def (find-in-defs name state)
+ (-> Ident Compiler (Maybe Type))
+ (let [[v-prefix v-name] name
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval?} state]
+ (case (get v-prefix modules)
+ #None
+ #None
+
+ (#Some {#defs defs #module-aliases _ #imports _})
+ (case (get v-name defs)
+ #None
+ #None
+
+ (#Some [_ def-data])
+ (case def-data
+ #TypeD (#Some Type)
+ (#ValueD type) (#Some type)
+ (#MacroD m) (#Some Macro)
+ (#AliasD name') (find-in-defs name' state))))))
+## (def (find-in-defs name state)
+## (-> Ident Compiler (Maybe Type))
+## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object]
+## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-defs #1: " (ident->text name) "\n")])
+## (let [[v-prefix v-name] name
+## {#source source #modules modules
+## #envs envs #types types #host host
+## #seed seed #eval? eval?} state]
+## (do Maybe/Monad
+## [module (get v-prefix modules)
+## #let [{#defs defs #module-aliases _ #imports _} module]
+## def (get v-name defs)
+## #let [[_ def-data] def]]
+## (case def-data
+## #TypeD (;return Type)
+## (#ValueD type) (;return type)
+## (#MacroD m) (;return Macro)
+## (#AliasD name') (find-in-defs name' state))))))
+
+(def (find-var-type name)
+ (-> Ident (Lux Type))
+ (do Lux/Monad
+ [name' (normalize name)]
+ (lambda [state]
+ (case (find-in-env name state)
+ (#Some struct-type)
+ (#Right [state struct-type])
+
+ _
+ (case (find-in-defs name' state)
+ (#Some struct-type)
+ (#Right [state struct-type])
+
+ _
+ (let [{#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval?} state]
+ (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))))
+
+(defmacro #export (using tokens)
+ (case tokens
+ (\ (list struct body))
+ (case struct
+ (#Meta [_ (#SymbolS name)])
+ (do Lux/Monad
+ [struct-type (find-var-type name)]
+ (case (resolve-struct-type struct-type)
+ (#Some (#RecordT slots))
+ (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[sname stype] slot
+ full-name (split-slot sname)]
+ [(tag$ full-name) (symbol$ full-name)])))
+ slots))]
+ (return (list (` (_lux_case (~ struct) (~ pattern) (~ body))))))
+
+ _
+ (fail "Can only \"use\" records.")))
+
+ _
+ (let [dummy (symbol$ ["" ""])]
+ (return (list (` (_lux_case (~ struct)
+ (~ dummy)
+ (using (~ dummy)
+ (~ body))))))))
+
+ _
+ (fail "Wrong syntax for using")))
+
+(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 [xy]
+ (let [[x y] xy]
+ (f x y))))
+
+(defmacro #export (cond tokens)
+ (if (i= 0 (i% (length tokens) 2))
+ (fail "cond requires an even number of arguments.")
+ (case (reverse tokens)
+ (\ (list& else branches'))
+ (return (list (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+ (lambda [else branch]
+ (let [[right left] branch]
+ (` (if (~ left) (~ right) (~ else))))))
+ else
+ (as-pairs branches'))))
+
+ _
+ (fail "Wrong syntax for cond"))))
+
+(defmacro #export (get@ tokens)
+ (case tokens
+ (\ (list (#Meta [_ (#TagS slot')]) record))
+ (case record
+ (#Meta [_ (#SymbolS name)])
+ (do Lux/Monad
+ [type (find-var-type name)
+ g!blank (gensym "")
+ g!output (gensym "")]
+ (case (resolve-struct-type type)
+ (#Some (#RecordT slots))
+ (do Lux/Monad
+ [slot (normalize slot')]
+ (let [[s-prefix s-name] (: Ident slot)
+ pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-type] slot
+ [r-prefix r-name] (split-slot r-slot-name)]
+ [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix)
+ (text:= s-name r-name))
+ g!output
+ g!blank)])))
+ slots))]
+ (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output)))))))
+
+ _
+ (fail "get@ can only use records.")))
+
+ _
+ (do Lux/Monad
+ [_record (gensym "")]
+ (return (list (` (let [(~ _record) (~ record)]
+ (get@ (~ (tag$ slot')) (~ _record))))))))
+
+ _
+ (fail "Wrong syntax for get@")))
+
+(defmacro #export (open tokens)
+ (case tokens
+ (\ (list (#Meta [_ (#SymbolS struct-name)])))
+ (do Lux/Monad
+ [struct-type (find-var-type struct-name)]
+ (case (resolve-struct-type struct-type)
+ (#Some (#RecordT slots))
+ (return (map (: (-> (, Text Type) Syntax)
+ (lambda [slot]
+ (let [[sname stype] slot
+ [module name] (split-slot sname)]
+ (` (_lux_def (~ (symbol$ ["" name]))
+ (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name))))))))
+ slots))
+
+ _
+ (fail "Can only \"open\" records.")))
+
+ _
+ (fail "Wrong syntax for open")))
+
+(def (foldL% M f x ys)
+ (All [m a b]
+ (-> (Monad m) (-> a b (m a)) a (List b)
+ (m a)))
+ (case ys
+ (#Cons [y ys'])
+ (do M
+ [x' (f x y)]
+ (foldL% M f x' ys'))
+
+ #Nil
+ ((get@ #return M) x)))
+
+(defmacro #export (:: tokens)
+ (case tokens
+ (\ (list& start parts))
+ (do Lux/Monad
+ [output (foldL% Lux/Monad
+ (: (-> Syntax Syntax (Lux Syntax))
+ (lambda [so-far part]
+ (case part
+ (#Meta [_ (#SymbolS slot)])
+ (return (` (get@ (~ (tag$ slot)) (~ so-far))))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))]))
+ (return (` ((get@ (~ (tag$ slot)) (~ so-far))
+ (~@ args))))
+
+ _
+ (fail "Wrong syntax for ::"))))
+ start parts)]
+ (return (list output)))
+
+ _
+ (fail "Wrong syntax for ::")))
+
+(defmacro #export (set@ tokens)
+ (case tokens
+ (\ (list (#Meta [_ (#TagS slot')]) value record))
+ (case record
+ (#Meta [_ (#SymbolS name)])
+ (do Lux/Monad
+ [type (find-var-type name)]
+ (case (resolve-struct-type type)
+ (#Some (#RecordT slots))
+ (do Lux/Monad
+ [pattern' (map% Lux/Monad
+ (: (-> (, Text Type) (Lux (, Text Syntax)))
+ (lambda [slot]
+ (let [[r-slot-name r-type] slot]
+ (do Lux/Monad
+ [g!slot (gensym "")]
+ (return [r-slot-name g!slot])))))
+ slots)
+ slot (normalize slot')]
+ (let [[s-prefix s-name] (: Ident slot)
+ pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-var] slot]
+ [(tag$ (split-slot r-slot-name)) r-var])))
+ pattern'))
+ output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-var] slot
+ [r-prefix r-name] (split-slot r-slot-name)]
+ [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix)
+ (text:= s-name r-name))
+ value
+ r-var)])))
+ pattern'))]
+ (return (list (` (_lux_case (~ record) (~ pattern) (~ output)))))))
+
+ _
+ (fail "set@ can only use records.")))
+
+ _
+ (do Lux/Monad
+ [_record (gensym "")]
+ (return (list (` (let [(~ _record) (~ record)]
+ (set@ (~ (tag$ slot')) (~ value) (~ _record))))))))
+
+ _
+ (fail "Wrong syntax for set@")))
+
+(defmacro #export (update@ tokens)
+ (case tokens
+ (\ (list (#Meta [_ (#TagS slot')]) fun record))
+ (case record
+ (#Meta [_ (#SymbolS name)])
+ (do Lux/Monad
+ [type (find-var-type name)]
+ (case (resolve-struct-type type)
+ (#Some (#RecordT slots))
+ (do Lux/Monad
+ [pattern' (map% Lux/Monad
+ (: (-> (, Text Type) (Lux (, Text Syntax)))
+ (lambda [slot]
+ (let [[r-slot-name r-type] slot]
+ (do Lux/Monad
+ [g!slot (gensym "")]
+ (return [r-slot-name g!slot])))))
+ slots)
+ slot (normalize slot')]
+ (let [[s-prefix s-name] (: Ident slot)
+ pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-var] slot]
+ [(tag$ (split-slot r-slot-name)) r-var])))
+ pattern'))
+ output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-var] slot
+ [r-prefix r-name] (split-slot r-slot-name)]
+ [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix)
+ (text:= s-name r-name))
+ (` ((~ fun) (~ r-var)))
+ r-var)])))
+ pattern'))]
+ (return (list (` (_lux_case (~ record) (~ pattern) (~ output)))))))
+
+ _
+ (fail "update@ can only use records.")))
+
+ _
+ (do Lux/Monad
+ [_record (gensym "")]
+ (return (list (` (let [(~ _record) (~ record)]
+ (update@ (~ (tag$ slot')) (~ fun) (~ _record))))))))
+
+ _
+ (fail "Wrong syntax for update@")))
+
+(defmacro #export (\template tokens)
+ (case tokens
+ (\ (list (#Meta [_ (#TupleS data)])
+ (#Meta [_ (#TupleS bindings)])
+ (#Meta [_ (#TupleS templates)])))
+ (case (: (Maybe (List Syntax))
+ (do Maybe/Monad
+ [bindings' (map% Maybe/Monad get-ident bindings)
+ data' (map% Maybe/Monad tuple->list data)]
+ (let [apply (: (-> RepEnv (List Syntax))
+ (lambda [env] (map (apply-template env) templates)))]
+ (|> data'
+ (join-map (. apply (make-env bindings')))
+ ;return))))
+ (#Some output)
+ (return output)
+
+ #None
+ (fail "Wrong syntax for \\template"))
+
+ _
+ (fail "Wrong syntax for \\template")))
+
+(def #export complement
+ (All [a] (-> (-> a Bool) (-> a Bool)))
+ (. not))
+
+## (defmacro #export (loop tokens)
+## (case tokens
+## (\ (list bindings body))
+## (let [pairs (as-pairs bindings)
+## vars (map first pairs)
+## inits (map second pairs)]
+## (if (every? symbol? inits)
+## (do Lux/Monad
+## [inits' (map% Maybe/Monad get-ident inits)
+## init-types (map% Maybe/Monad find-var-type inits')]
+## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)]
+## (~ body))
+## (~@ inits))))))
+## (do Lux/Monad
+## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)]
+## (return (list (` (let [(~@ (interleave aliases inits))]
+## (loop [(~@ (interleave vars aliases))]
+## (~ body)))))))))
+
+## _
+## (fail "Wrong syntax for loop")))
diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux
new file mode 100644
index 000000000..1d6dd1b50
--- /dev/null
+++ b/source/lux/codata/stream.lux
@@ -0,0 +1,133 @@
+## 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.
+
+(;import lux
+ (lux (control (lazy #as L #refer #all)
+ (functor #as F #refer #all)
+ (monad #as M #refer #all)
+ (comonad #as CM #refer #all))
+ (meta lux
+ macro
+ syntax)
+ (data (list #as l #refer (#only list list& List/Monad)))))
+
+## [Types]
+(deftype #export (Stream a)
+ (Lazy (, a (Stream a))))
+
+## [Utils]
+(def (cycle' x xs init full)
+ (All [a]
+ (-> a (List a) a (List a) (Stream a)))
+ (case xs
+ #;Nil (cycle' init full init full)
+ (#;Cons [y xs']) (... [x (cycle' y xs' init full)])))
+
+## [Functions]
+(def #export (iterate f x)
+ (All [a]
+ (-> (-> a a) a (Stream a)))
+ (... [x (iterate f (f x))]))
+
+(def #export (repeat x)
+ (All [a]
+ (-> a (Stream a)))
+ (... [x (repeat x)]))
+
+(def #export (cycle xs)
+ (All [a]
+ (-> (List a) (Maybe (Stream a))))
+ (case xs
+ #;Nil #;None
+ (#;Cons [x xs']) (#;Some (cycle' x xs' x xs'))))
+
+(do-template [<name> <return> <part>]
+ [(def #export (<name> s)
+ (All [a] (-> (Stream a) <return>))
+ (let [[h t] (! s)]
+ <part>))]
+
+ [head a h]
+ [tail (Stream a) t])
+
+(def #export (@ idx s)
+ (All [a] (-> Int (Stream a) a))
+ (let [[h t] (! s)]
+ (if (i> idx 0)
+ (@ (dec idx) t)
+ h)))
+
+(do-template [<taker> <dropper> <splitter> <det-type> <det-test> <det-step>]
+ [(def #export (<taker> det xs)
+ (All [a]
+ (-> <det-type> (Stream a) (List a)))
+ (let [[x xs'] (! xs)]
+ (if <det-test>
+ (list& x (<taker> <det-step> xs'))
+ (list))))
+
+ (def #export (<dropper> det xs)
+ (All [a]
+ (-> <det-type> (Stream a) (Stream a)))
+ (let [[x xs'] (! xs)]
+ (if <det-test>
+ (<dropper> <det-step> xs')
+ xs)))
+
+ (def #export (<splitter> det xs)
+ (All [a]
+ (-> <det-type> (Stream a) (, (List a) (Stream a))))
+ (let [[x xs'] (! xs)]
+ (if <det-test>
+ (let [[tail next] (<splitter> <det-step> xs')]
+ [(#;Cons [x tail]) next])
+ [(list) xs])))]
+
+ [take-while drop-while split-with (-> a Bool) (det x) det]
+ [take drop split Int (i> det 0) (dec det)]
+ )
+
+(def #export (unfold step init)
+ (All [a b]
+ (-> (-> a (, a b)) a (Stream b)))
+ (let [[next x] (step init)]
+ (... [x (unfold step next)])))
+
+(def #export (filter p xs)
+ (All [a] (-> (-> a Bool) (Stream a) (Stream a)))
+ (let [[x xs'] (! xs)]
+ (if (p x)
+ (... [x (filter p xs')])
+ (filter p xs'))))
+
+(def #export (partition p xs)
+ (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a))))
+ [(filter p xs) (filter (complement p) xs)])
+
+## [Structures]
+(defstruct #export Stream/Functor (Functor Stream)
+ (def (F;map f fa)
+ (let [[h t] (! fa)]
+ (... [(f h) (F;map f t)]))))
+
+(defstruct #export Stream/CoMonad (CoMonad Stream)
+ (def CM;_functor Stream/Functor)
+ (def CM;unwrap head)
+ (def (CM;split wa)
+ (:: Stream/Functor (F;map repeat wa))))
+
+## [Pattern-matching]
+(defsyntax #export (\stream body [patterns' (+^ id^)])
+ (do Lux/Monad
+ [patterns (map% Lux/Monad macro-expand-1 patterns')
+ g!s (gensym "s")
+ #let [patterns+ (: (List Syntax)
+ (do List/Monad
+ [pattern (l;reverse patterns)]
+ (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]]
+ (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body)))))))
diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux
new file mode 100644
index 000000000..1830ff44f
--- /dev/null
+++ b/source/lux/control/comonad.lux
@@ -0,0 +1,54 @@
+## 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.
+
+(;import lux
+ (../functor #as F)
+ lux/data/list
+ lux/meta/macro)
+
+## Signatures
+(defsig #export (CoMonad w)
+ (: (F;Functor w)
+ _functor)
+ (: (All [a]
+ (-> (w a) a))
+ unwrap)
+ (: (All [a]
+ (-> (w a) (w (w a))))
+ split))
+
+## Functions
+(def #export (extend w f ma)
+ (All [w a b]
+ (-> (CoMonad w) (-> (w a) b) (w a) (w b)))
+ (using w
+ (using ;;_functor
+ (F;map f (;;split ma)))))
+
+## Syntax
+(defmacro #export (be tokens state)
+ (case tokens
+ (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body))
+ (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+ (lambda [body' binding]
+ (let [[var value] binding]
+ (case var
+ (#;Meta [_ (#;TagS ["" "let"])])
+ (` (;let (~ value) (~ body')))
+
+ _
+ (` (extend (;lambda [(~ var)] (~ body'))
+ (~ value)))))))
+ body
+ (reverse (as-pairs bindings)))]
+ (#;Right [state (list (` (;case (~ monad)
+ {#;return ;return #;bind ;bind}
+ (~ body'))))]))
+
+ _
+ (#;Left "Wrong syntax for be")))
diff --git a/source/lux/control/functor.lux b/source/lux/control/functor.lux
new file mode 100644
index 000000000..6a9dcfff8
--- /dev/null
+++ b/source/lux/control/functor.lux
@@ -0,0 +1,15 @@
+## 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.
+
+(;import lux)
+
+## Signatures
+(defsig #export (Functor f)
+ (: (All [a b]
+ (-> (-> a b) (f a) (f b)))
+ map))
diff --git a/source/lux/control/lazy.lux b/source/lux/control/lazy.lux
new file mode 100644
index 000000000..22dac74fe
--- /dev/null
+++ b/source/lux/control/lazy.lux
@@ -0,0 +1,47 @@
+## 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.
+
+(;import lux
+ (lux/meta macro)
+ (.. (functor #as F #refer #all)
+ (monad #as M #refer #all))
+ (lux/data list))
+
+## Types
+(deftype #export (Lazy a)
+ (All [b]
+ (-> (-> a b) b)))
+
+## Syntax
+(defmacro #export (... tokens state)
+ (case tokens
+ (\ (list value))
+ (let [blank (symbol$ ["" ""])]
+ (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))]))
+
+ _
+ (#;Left "Wrong syntax for ...")))
+
+## Functions
+(def #export (! thunk)
+ (All [a]
+ (-> (Lazy a) a))
+ (thunk id))
+
+## Structs
+(defstruct #export Lazy/Functor (Functor Lazy)
+ (def (F;map f ma)
+ (lambda [k] (ma (. k f)))))
+
+(defstruct #export Lazy/Monad (Monad Lazy)
+ (def M;_functor Lazy/Functor)
+
+ (def (M;wrap a)
+ (... a))
+
+ (def M;join !))
diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux
new file mode 100644
index 000000000..b5552f987
--- /dev/null
+++ b/source/lux/control/monad.lux
@@ -0,0 +1,99 @@
+## 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.
+
+(;import lux
+ (.. (functor #as F)
+ (monoid #as M))
+ lux/meta/macro)
+
+## [Utils]
+(def (foldL f init xs)
+ (All [a b]
+ (-> (-> a b a) a (List b) a))
+ (case xs
+ #;Nil
+ init
+
+ (#;Cons [x xs'])
+ (foldL f (f init x) xs')))
+
+(def (reverse xs)
+ (All [a]
+ (-> (List a) (List a)))
+ (foldL (lambda [tail head] (#;Cons [head tail]))
+ #;Nil
+ xs))
+
+(def (as-pairs xs)
+ (All [a] (-> (List a) (List (, a a))))
+ (case xs
+ (#;Cons [x1 (#;Cons [x2 xs'])])
+ (#;Cons [[x1 x2] (as-pairs xs')])
+
+ _
+ #;Nil))
+
+## [Signatures]
+(defsig #export (Monad m)
+ (: (F;Functor m)
+ _functor)
+ (: (All [a]
+ (-> a (m a)))
+ wrap)
+ (: (All [a]
+ (-> (m (m a)) (m a)))
+ join))
+
+## [Syntax]
+(defmacro #export (do tokens state)
+ (case tokens
+ ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body))
+ (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])])
+ (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+ (lambda [body' binding]
+ (let [[var value] binding]
+ (case var
+ (#;Meta [_ (#;TagS ["" "let"])])
+ (` (;let (~ value) (~ body')))
+
+ _
+ (` (;case ;;_functor
+ {#F;map F;map}
+ (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join))))
+ ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join)))
+ ))))
+ body
+ (reverse (as-pairs bindings)))]
+ (#;Right [state (#;Cons [(` (;case (~ monad)
+ {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join}
+ (~ body')))
+ #;Nil])]))
+
+ _
+ (#;Left "Wrong syntax for do")))
+
+## [Functions]
+(def #export (bind m f ma)
+ (All [m a b]
+ (-> (Monad m) (-> a (m b)) (m a) (m b)))
+ (using m
+ (;;join (:: ;;_functor (F;map f ma)))))
+
+(def #export (map% m f xs)
+ (All [m a b]
+ (-> (Monad m) (-> a (m b)) (List a) (m (List b))))
+ (case xs
+ #;Nil
+ (:: m (;;wrap #;Nil))
+
+ (#;Cons [x xs'])
+ (do m
+ [y (f x)
+ ys (map% m f xs')]
+ (;;wrap (#;Cons [y ys])))
+ ))
diff --git a/source/lux/control/monoid.lux b/source/lux/control/monoid.lux
new file mode 100644
index 000000000..d32baabc5
--- /dev/null
+++ b/source/lux/control/monoid.lux
@@ -0,0 +1,24 @@
+## 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.
+
+(;import lux)
+
+## Signatures
+(defsig #export (Monoid a)
+ (: a
+ unit)
+ (: (-> a a a)
+ ++))
+
+## Constructors
+(def #export (monoid$ unit ++)
+ (All [a]
+ (-> a (-> a a a) (Monoid a)))
+ (struct
+ (def unit unit)
+ (def ++ ++)))
diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux
new file mode 100644
index 000000000..d4f223612
--- /dev/null
+++ b/source/lux/data/bool.lux
@@ -0,0 +1,33 @@
+## 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.
+
+(;import lux
+ (lux/control (monoid #as m))
+ (.. (eq #as E)
+ (show #as S)))
+
+## [Structures]
+(defstruct #export Bool/Eq (E;Eq Bool)
+ (def (E;= x y)
+ (if x
+ y
+ (not y))))
+
+(defstruct #export Bool/Show (S;Show Bool)
+ (def (S;show x)
+ (if x "true" "false")))
+
+(do-template [<name> <unit> <op>]
+ [(defstruct #export <name> (m;Monoid Bool)
+ (def m;unit <unit>)
+ (def (m;++ x y)
+ (<op> x y)))]
+
+ [ Or/Monoid false or]
+ [And/Monoid true and]
+ )
diff --git a/source/lux/data/bounded.lux b/source/lux/data/bounded.lux
new file mode 100644
index 000000000..9d2dabde1
--- /dev/null
+++ b/source/lux/data/bounded.lux
@@ -0,0 +1,17 @@
+## 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.
+
+(;import lux)
+
+## Signatures
+(defsig #export (Bounded a)
+ (: a
+ top)
+
+ (: a
+ bottom))
diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux
new file mode 100644
index 000000000..42e57509e
--- /dev/null
+++ b/source/lux/data/char.lux
@@ -0,0 +1,20 @@
+## 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.
+
+(;import lux
+ (.. (eq #as E)
+ (show #as S)))
+
+## [Structures]
+(defstruct #export Char/Eq (E;Eq Char)
+ (def (E;= x y)
+ (_jvm_ceq x y)))
+
+(defstruct #export Char/Show (S;Show Char)
+ (def (S;show x)
+ ($ text:++ "#\"" (_jvm_invokevirtual java.lang.Object toString [] x []) "\"")))
diff --git a/source/lux/data/dict.lux b/source/lux/data/dict.lux
new file mode 100644
index 000000000..63a66d49b
--- /dev/null
+++ b/source/lux/data/dict.lux
@@ -0,0 +1,83 @@
+## 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.
+
+(;import lux
+ (lux/data (eq #as E)))
+
+## Signatures
+(defsig #export (Dict d)
+ (: (All [k v]
+ (-> k (d k v) (Maybe v)))
+ get)
+ (: (All [k v]
+ (-> k v (d k v) (d k v)))
+ put)
+ (: (All [k v]
+ (-> k (d k v) (d k v)))
+ remove))
+
+## Types
+(deftype #export (PList k v)
+ (| (#PList (, (E;Eq k) (List (, k v))))))
+
+## Constructors
+(def #export (plist eq)
+ (All [k v]
+ (-> (E;Eq k) (PList k v)))
+ (#PList [eq #;Nil]))
+
+## Utils
+(def (pl-get eq k kvs)
+ (All [k v]
+ (-> (E;Eq k) k (List (, k v)) (Maybe v)))
+ (case kvs
+ #;Nil
+ #;None
+
+ (#;Cons [[k' v'] kvs'])
+ (if (:: eq (E;= k k'))
+ (#;Some v')
+ (pl-get eq k kvs'))))
+
+(def (pl-put eq k v kvs)
+ (All [k v]
+ (-> (E;Eq k) k v (List (, k v)) (List (, k v))))
+ (case kvs
+ #;Nil
+ (#;Cons [[k v] kvs])
+
+ (#;Cons [[k' v'] kvs'])
+ (if (:: eq (E;= k k'))
+ (#;Cons [[k v] kvs'])
+ (#;Cons [[k' v'] (pl-put eq k v kvs')]))))
+
+(def (pl-remove eq k kvs)
+ (All [k v]
+ (-> (E;Eq k) k (List (, k v)) (List (, k v))))
+ (case kvs
+ #;Nil
+ kvs
+
+ (#;Cons [[k' v'] kvs'])
+ (if (:: eq (E;= k k'))
+ kvs'
+ (#;Cons [[k' v'] (pl-remove eq k kvs')]))))
+
+## Structs
+(defstruct #export PList/Dict (Dict PList)
+ (def (get k plist)
+ (let [(#PList [eq kvs]) plist]
+ (pl-get eq k kvs)))
+
+ (def (put k v plist)
+ (let [(#PList [eq kvs]) plist]
+ (#PList [eq (pl-put eq k v kvs)])))
+
+ (def (remove k plist)
+ (let [(#PList [eq kvs]) plist]
+ (#PList [eq (pl-remove eq k kvs)]))))
diff --git a/source/lux/data/either.lux b/source/lux/data/either.lux
new file mode 100644
index 000000000..eba6438db
--- /dev/null
+++ b/source/lux/data/either.lux
@@ -0,0 +1,46 @@
+## 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.
+
+(;import lux
+ (lux/data (list #refer (#exclude partition))))
+
+## [Types]
+## (deftype (Either l r)
+## (| (#;Left l)
+## (#;Right r)))
+
+## [Functions]
+(def #export (either f g e)
+ (All [a b c] (-> (-> a c) (-> b c) (Either a b) c))
+ (case e
+ (#;Left x) (f x)
+ (#;Right x) (g x)))
+
+(do-template [<name> <side> <tag>]
+ [(def #export (<name> es)
+ (All [a b] (-> (List (Either a b)) (List <side>)))
+ (case es
+ #;Nil #;Nil
+ (#;Cons [(<tag> x) es']) (#;Cons [x (<name> es')])
+ (#;Cons [_ es']) (<name> es')))]
+
+ [lefts a #;Left]
+ [rights b #;Right]
+ )
+
+(def #export (partition es)
+ (All [a b] (-> (List (Either a b)) (, (List a) (List b))))
+ (foldL (: (All [a b]
+ (-> (, (List a) (List b)) (Either a b) (, (List a) (List b))))
+ (lambda [tails e]
+ (let [[ltail rtail] tails]
+ (case e
+ (#;Left x) [(#;Cons [x ltail]) rtail]
+ (#;Right x) [ltail (#;Cons [x rtail])]))))
+ [(list) (list)]
+ (reverse es)))
diff --git a/source/lux/data/eq.lux b/source/lux/data/eq.lux
new file mode 100644
index 000000000..be3400208
--- /dev/null
+++ b/source/lux/data/eq.lux
@@ -0,0 +1,14 @@
+## 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.
+
+(;import lux)
+
+## [Signatures]
+(defsig #export (Eq a)
+ (: (-> a a Bool)
+ =))
diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux
new file mode 100644
index 000000000..cb5c309a6
--- /dev/null
+++ b/source/lux/data/error.lux
@@ -0,0 +1,34 @@
+## 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.
+
+(;import lux
+ (lux/control (functor #as F #refer #all)
+ (monad #as M #refer #all)))
+
+## [Types]
+(deftype #export (Error a)
+ (| (#Fail Text)
+ (#Ok a)))
+
+## [Structures]
+(defstruct #export Error/Functor (Functor Error)
+ (def (F;map f ma)
+ (case ma
+ (#Fail msg) (#Fail msg)
+ (#Ok datum) (#Ok (f datum)))))
+
+(defstruct #export Error/Monad (Monad Error)
+ (def M;_functor Error/Functor)
+
+ (def (M;wrap a)
+ (#Ok a))
+
+ (def (M;join mma)
+ (case mma
+ (#Fail msg) (#Fail msg)
+ (#Ok ma) ma)))
diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux
new file mode 100644
index 000000000..0e3bdbee6
--- /dev/null
+++ b/source/lux/data/id.lux
@@ -0,0 +1,28 @@
+## 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.
+
+(;import lux
+ (lux/control (functor #as F #refer #all)
+ (monad #as M #refer #all)))
+
+## [Types]
+(deftype #export (Id a)
+ (| (#Id a)))
+
+## [Structures]
+(defstruct #export Id/Functor (Functor Id)
+ (def (F;map f fa)
+ (let [(#Id a) fa]
+ (#Id (f a)))))
+
+(defstruct #export Id/Monad (Monad Id)
+ (def M;_functor Id/Functor)
+ (def (M;wrap a) (#Id a))
+ (def (M;join mma)
+ (let [(#Id ma) mma]
+ ma)))
diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux
new file mode 100644
index 000000000..c08023df5
--- /dev/null
+++ b/source/lux/data/io.lux
@@ -0,0 +1,51 @@
+## 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.
+
+(;import lux
+ (lux/meta macro)
+ (lux/control (functor #as F)
+ (monad #as M))
+ lux/data/list)
+
+## Types
+(deftype #export (IO a)
+ (-> (,) a))
+
+## Syntax
+(defmacro #export (io tokens state)
+ (case tokens
+ (\ (list value))
+ (let [blank (symbol$ ["" ""])]
+ (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))]))
+
+ _
+ (#;Left "Wrong syntax for io")))
+
+## Structures
+(defstruct #export IO/Functor (F;Functor IO)
+ (def (F;map f ma)
+ (io (f (ma [])))))
+
+(defstruct #export IO/Monad (M;Monad IO)
+ (def M;_functor IO/Functor)
+
+ (def (M;wrap x)
+ (io x))
+
+ (def (M;join mma)
+ (mma [])))
+
+## Functions
+(def #export (print x)
+ (-> Text (IO (,)))
+ (io (_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")))
diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux
new file mode 100644
index 000000000..450dee275
--- /dev/null
+++ b/source/lux/data/list.lux
@@ -0,0 +1,250 @@
+## 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.
+
+(;import lux
+ (lux/control (monoid #as m #refer #all)
+ (functor #as F #refer #all)
+ (monad #as M #refer #all))
+ lux/meta/macro)
+
+## Types
+## (deftype (List a)
+## (| #Nil
+## (#Cons (, a (List a)))))
+
+## Functions
+(def #export (foldL f init xs)
+ (All [a b]
+ (-> (-> a b a) a (List b) a))
+ (case xs
+ #;Nil
+ init
+
+ (#;Cons [x xs'])
+ (foldL f (f init x) xs')))
+
+(def #export (foldR f init xs)
+ (All [a b]
+ (-> (-> b a a) a (List b) a))
+ (case xs
+ #;Nil
+ init
+
+ (#;Cons [x xs'])
+ (f x (foldR f init xs'))))
+
+(def #export (reverse xs)
+ (All [a]
+ (-> (List a) (List a)))
+ (foldL (lambda [tail head] (#;Cons [head tail]))
+ #;Nil
+ xs))
+
+(def #export (filter p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (List a)))
+ (case xs
+ #;Nil
+ #;Nil
+
+ (#;Cons [x xs'])
+ (if (p x)
+ (#;Cons [x (filter p xs')])
+ (filter p xs'))))
+
+(def #export (partition p xs)
+ (All [a] (-> (-> a Bool) (List a) (, (List a) (List a))))
+ [(filter p xs) (filter (complement p) xs)])
+
+(def #export (as-pairs xs)
+ (All [a] (-> (List a) (List (, a a))))
+ (case xs
+ (\ (#;Cons [x1 (#;Cons [x2 xs'])]))
+ (#;Cons [[x1 x2] (as-pairs xs')])
+
+ _
+ #;Nil))
+
+(do-template [<name> <then> <else>]
+ [(def #export (<name> n xs)
+ (All [a]
+ (-> Int (List a) (List a)))
+ (if (i> n 0)
+ (case xs
+ #;Nil
+ #;Nil
+
+ (#;Cons [x xs'])
+ <then>)
+ <else>))]
+
+ [take (#;Cons [x (take (dec n) xs')]) #;Nil]
+ [drop (drop (dec n) xs') xs]
+ )
+
+(do-template [<name> <then> <else>]
+ [(def #export (<name> p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (List a)))
+ (case xs
+ #;Nil
+ #;Nil
+
+ (#;Cons [x xs'])
+ (if (p x)
+ <then>
+ <else>)))]
+
+ [take-while (#;Cons [x (take-while p xs')]) #;Nil]
+ [drop-while (drop-while p xs') xs]
+ )
+
+(def #export (split n xs)
+ (All [a]
+ (-> Int (List a) (, (List a) (List a))))
+ (if (i> n 0)
+ (case xs
+ #;Nil
+ [#;Nil #;Nil]
+
+ (#;Cons [x xs'])
+ (let [[tail rest] (split (dec n) xs')]
+ [(#;Cons [x tail]) rest]))
+ [#;Nil xs]))
+
+(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 (#;Cons [x ys]) xs')
+ [ys xs])))
+
+(def #export (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 #export (repeat n x)
+ (All [a]
+ (-> Int a (List a)))
+ (if (i> n 0)
+ (#;Cons [x (repeat (dec n) x)])
+ #;Nil))
+
+(def #export (iterate f x)
+ (All [a]
+ (-> (-> a (Maybe a)) a (List a)))
+ (case (f x)
+ (#;Some x')
+ (#;Cons [x (iterate f x')])
+
+ #;None
+ (#;Cons [x #;Nil])))
+
+(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 #export (interpose sep xs)
+ (All [a]
+ (-> a (List a) (List a)))
+ (case xs
+ #;Nil
+ xs
+
+ (#;Cons [x #;Nil])
+ xs
+
+ (#;Cons [x xs'])
+ (#;Cons [x (#;Cons [sep (interpose sep xs')])])))
+
+(def #export (size list)
+ (-> List Int)
+ (foldL (lambda [acc _] (i+ 1 acc)) 0 list))
+
+(do-template [<name> <init> <op>]
+ [(def #export (<name> p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) Bool))
+ (foldL (lambda [_1 _2] (<op> _1 (p _2))) <init> xs))]
+
+ [every? true and]
+ [any? false or])
+
+(def #export (@ i xs)
+ (All [a]
+ (-> Int (List a) (Maybe a)))
+ (case xs
+ #;Nil
+ #;None
+
+ (#;Cons [x xs'])
+ (if (i= 0 i)
+ (#;Some x)
+ (@ (dec i) xs'))))
+
+## Syntax
+(defmacro #export (list xs state)
+ (#;Right [state (#;Cons [(foldL (lambda [tail head]
+ (` (#;Cons [(~ head) (~ tail)])))
+ (` #;Nil)
+ (reverse xs))
+ #;Nil])]))
+
+(defmacro #export (list& xs state)
+ (case (reverse xs)
+ (#;Cons [last init])
+ (#;Right [state (list (foldL (lambda [tail head]
+ (` (#;Cons [(~ head) (~ tail)])))
+ last
+ init))])
+
+ _
+ (#;Left "Wrong syntax for list&")))
+
+## Structures
+(defstruct #export List/Monoid (All [a]
+ (Monoid (List a)))
+ (def m;unit #;Nil)
+ (def (m;++ xs ys)
+ (case xs
+ #;Nil ys
+ (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)]))))
+
+(defstruct #export List/Functor (Functor List)
+ (def (F;map f ma)
+ (case ma
+ #;Nil #;Nil
+ (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')]))))
+
+(defstruct #export List/Monad (Monad List)
+ (def M;_functor List/Functor)
+
+ (def (M;wrap a)
+ (#;Cons [a #;Nil]))
+
+ (def (M;join mma)
+ (using List/Monoid
+ (foldL m;++ m;unit mma))))
diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux
new file mode 100644
index 000000000..faec53c2e
--- /dev/null
+++ b/source/lux/data/maybe.lux
@@ -0,0 +1,42 @@
+## 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.
+
+(;import lux
+ (lux/control (monoid #as m #refer #all)
+ (functor #as F #refer #all)
+ (monad #as M #refer #all)))
+
+## [Types]
+## (deftype (Maybe a)
+## (| #;None
+## (#;Some a)))
+
+## [Structures]
+(defstruct #export Maybe/Monoid (Monoid Maybe)
+ (def m;unit #;None)
+ (def (m;++ xs ys)
+ (case xs
+ #;None ys
+ (#;Some x) (#;Some x))))
+
+(defstruct #export Maybe/Functor (Functor Maybe)
+ (def (F;map f ma)
+ (case ma
+ #;None #;None
+ (#;Some a) (#;Some (f a)))))
+
+(defstruct #export Maybe/Monad (Monad Maybe)
+ (def M;_functor Maybe/Functor)
+
+ (def (M;wrap x)
+ (#;Some x))
+
+ (def (M;join mma)
+ (case mma
+ #;None #;None
+ (#;Some xs) xs)))
diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux
new file mode 100644
index 000000000..8da674d88
--- /dev/null
+++ b/source/lux/data/number.lux
@@ -0,0 +1,119 @@
+## 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.
+
+(;import lux
+ (lux/control (monoid #as m))
+ (lux/data (eq #as E)
+ (ord #as O)
+ (bounded #as B)
+ (show #as S)))
+
+## Signatures
+(defsig #export (Number n)
+ (do-template [<name>]
+ [(: (-> n n n) <name>)]
+ [+] [-] [*] [/] [%])
+
+ (: (-> Int n)
+ from-int)
+
+ (do-template [<name>]
+ [(: (-> n n) <name>)]
+ [negate] [signum] [abs])
+ )
+
+## [Structures]
+## Number
+(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>]
+ [(defstruct #export <name> (Number <type>)
+ (def + <+>)
+ (def - <->)
+ (def * <*>)
+ (def / </>)
+ (def % <%>)
+ (def (from-int x)
+ (<from> x))
+ (def (negate x)
+ (<*> <-1> x))
+ (def (abs x)
+ (if (<<> x <0>)
+ (<*> <-1> x)
+ x))
+ (def (signum x)
+ (cond (<=> x <0>) <0>
+ (<<> x <0>) <-1>
+ ## else
+ <1>))
+ )]
+
+ [ Int/Number Int i+ i- i* i/ i% i= i< id 0 1 -1]
+ [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0])
+
+## Eq
+(defstruct #export Int/Eq (E;Eq Int)
+ (def E;= i=))
+
+(defstruct #export Real/Eq (E;Eq Real)
+ (def E;= r=))
+
+## Ord
+## (def #export Int/Ord (O;Ord Int)
+## (O;ord$ Int/Eq i< i>))
+
+## (def #export Real/Ord (O;Ord Real)
+## (O;ord$ Real/Eq r< r>))
+
+(do-template [<name> <type> <eq> <lt> <gt>]
+ [(defstruct #export <name> (O;Ord <type>)
+ (def O;_eq <eq>)
+ (def O;< <lt>)
+ (def (O;<= x y)
+ (or (<lt> x y)
+ (using <eq> (E;= x y))))
+ (def O;> <gt>)
+ (def (O;>= x y)
+ (or (<gt> x y)
+ (using <eq> (E;= x y)))))]
+
+ [ Int/Ord Int Int/Eq i< i>]
+ [Real/Ord Real Real/Eq r< r>])
+
+## Bounded
+(do-template [<name> <type> <top> <bottom>]
+ [(defstruct #export <name> (B;Bounded <type>)
+ (def B;top <top>)
+ (def B;bottom <bottom>))]
+
+ [ Int/Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)]
+ [Real/Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)])
+
+## Monoid
+(do-template [<name> <type> <unit> <++>]
+ [(defstruct #export <name> (m;Monoid <type>)
+ (def m;unit <unit>)
+ (def m;++ <++>))]
+
+ [ IntAdd/Monoid Int 0 i+]
+ [ IntMul/Monoid Int 1 i*]
+ [RealAdd/Monoid Real 0.0 r+]
+ [RealMul/Monoid Real 1.0 r*]
+ [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)]
+ [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)]
+ [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)]
+ [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)]
+ )
+
+## Show
+(do-template [<name> <type> <body>]
+ [(defstruct #export <name> (S;Show <type>)
+ (def (S;show x)
+ <body>))]
+
+ [ Int/Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])]
+ [Real/Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])]
+ )
diff --git a/source/lux/data/ord.lux b/source/lux/data/ord.lux
new file mode 100644
index 000000000..80f2e4fb5
--- /dev/null
+++ b/source/lux/data/ord.lux
@@ -0,0 +1,44 @@
+## 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.
+
+(;import lux
+ (../eq #as E))
+
+## [Signatures]
+(defsig #export (Ord a)
+ (: (E;Eq a)
+ _eq)
+ (do-template [<name>]
+ [(: (-> a a Bool) <name>)]
+
+ [<] [<=] [>] [>=]))
+
+## [Constructors]
+(def #export (ord$ eq < >)
+ (All [a]
+ (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a)))
+ (struct
+ (def _eq eq)
+ (def < <)
+ (def (<= x y)
+ (or (< x y)
+ (:: eq (E;= x y))))
+ (def > >)
+ (def (>= x y)
+ (or (> x y)
+ (:: eq (E;= x y))))))
+
+## [Functions]
+(do-template [<name> <op>]
+ [(def #export (<name> ord x y)
+ (All [a]
+ (-> (Ord a) a a a))
+ (if (:: ord (<op> x y)) x y))]
+
+ [max ;;>]
+ [min ;;<])
diff --git a/source/lux/data/reader.lux b/source/lux/data/reader.lux
new file mode 100644
index 000000000..e91687c3a
--- /dev/null
+++ b/source/lux/data/reader.lux
@@ -0,0 +1,33 @@
+## 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.
+
+(;import (lux #refer (#exclude Reader))
+ (lux/control (functor #as F #refer #all)
+ (monad #as M #refer #all)))
+
+## [Types]
+(deftype #export (Reader r a)
+ (-> r a))
+
+## [Structures]
+(defstruct #export Reader/Functor (All [r]
+ (Functor (Reader r)))
+ (def (F;map f fa)
+ (lambda [env]
+ (f (fa env)))))
+
+(defstruct #export Reader/Monad (All [r]
+ (Monad (Reader r)))
+ (def M;_functor Reader/Functor)
+
+ (def (M;wrap x)
+ (lambda [env] x))
+
+ (def (M;join mma)
+ (lambda [env]
+ (mma env env))))
diff --git a/source/lux/data/show.lux b/source/lux/data/show.lux
new file mode 100644
index 000000000..f4e1cf762
--- /dev/null
+++ b/source/lux/data/show.lux
@@ -0,0 +1,14 @@
+## 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.
+
+(;import lux)
+
+## Signatures
+(defsig #export (Show a)
+ (: (-> a Text)
+ show))
diff --git a/source/lux/data/state.lux b/source/lux/data/state.lux
new file mode 100644
index 000000000..bc9858a29
--- /dev/null
+++ b/source/lux/data/state.lux
@@ -0,0 +1,35 @@
+## 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.
+
+(;import lux
+ (lux/control (functor #as F #refer #all)
+ (monad #as M #refer #all)))
+
+## [Types]
+(deftype #export (State s a)
+ (-> s (, s a)))
+
+## [Structures]
+(defstruct #export State/Functor (Functor State)
+ (def (F;map f ma)
+ (lambda [state]
+ (let [[state' a] (ma state)]
+ [state' (f a)]))))
+
+(defstruct #export State/Monad (All [s]
+ (Monad (State s)))
+ (def M;_functor State/Functor)
+
+ (def (M;wrap x)
+ (lambda [state]
+ [state x]))
+
+ (def (M;join mma)
+ (lambda [state]
+ (let [[state' ma] (mma state)]
+ (ma state')))))
diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux
new file mode 100644
index 000000000..a3192a1d5
--- /dev/null
+++ b/source/lux/data/text.lux
@@ -0,0 +1,146 @@
+## 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.
+
+(;import lux
+ (lux/control (monoid #as m))
+ (lux/data (eq #as E)
+ (ord #as O)
+ (show #as S)))
+
+## [Functions]
+(def #export (size x)
+ (-> Text Int)
+ (_jvm_i2l (_jvm_invokevirtual java.lang.String length []
+ x [])))
+
+(def #export (@ idx x)
+ (-> Int Text (Maybe Char))
+ (if (and (i< idx (size x))
+ (i>= idx 0))
+ (#;Some (_jvm_invokevirtual java.lang.String charAt [int]
+ x [(_jvm_l2i idx)]))
+ #;None))
+
+(def #export (contains? x y)
+ (-> Text Text Bool)
+ (_jvm_invokevirtual java.lang.String contains [java.lang.CharSequence]
+ x [y]))
+
+(do-template [<name> <method>]
+ [(def #export (<name> x)
+ (-> Text Text)
+ (_jvm_invokevirtual java.lang.String <method> []
+ x []))]
+ [lower-case toLowerCase]
+ [upper-case toUpperCase]
+ [trim trim]
+ )
+
+(def #export (sub' from to x)
+ (-> Int Int Text (Maybe Text))
+ (if (and (i< from to)
+ (i>= from 0)
+ (i<= to (size x)))
+ (_jvm_invokevirtual java.lang.String substring [int int]
+ x [(_jvm_l2i from) (_jvm_l2i to)])
+ #;None))
+
+(def #export (sub from x)
+ (-> Int Text (Maybe Text))
+ (sub' from (size x) x))
+
+(def #export (split at x)
+ (-> Int Text (Maybe (, Text Text)))
+ (if (and (i< at (size x))
+ (i>= at 0))
+ (let [pre (_jvm_invokevirtual java.lang.String substring [int int]
+ x [(_jvm_l2i 0) (_jvm_l2i at)])
+ post (_jvm_invokevirtual java.lang.String substring [int]
+ x [(_jvm_l2i at)])]
+ (#;Some [pre post]))
+ #;None))
+
+(def #export (replace pattern value template)
+ (-> Text Text Text Text)
+ (_jvm_invokevirtual java.lang.String replace [java.lang.CharSequence java.lang.CharSequence]
+ template [pattern value]))
+
+(do-template [<common> <general> <method>]
+ [(def #export (<general> pattern from x)
+ (-> Text Int Text (Maybe Int))
+ (if (and (i< from (size x)) (i>= from 0))
+ (case (_jvm_i2l (_jvm_invokevirtual java.lang.String <method> [java.lang.String int]
+ x [pattern (_jvm_l2i from)]))
+ -1 #;None
+ idx (#;Some idx))
+ #;None))
+
+ (def #export (<common> pattern x)
+ (-> Text Text (Maybe Int))
+ (case (_jvm_i2l (_jvm_invokevirtual java.lang.String <method> [java.lang.String]
+ x [pattern]))
+ -1 #;None
+ idx (#;Some idx)))]
+
+ [index-of index-of' indexOf]
+ [last-index-of last-index-of' lastIndexOf]
+ )
+
+(def #export (starts-with? prefix x)
+ (-> Text Text Bool)
+ (case (index-of prefix x)
+ (#;Some 0)
+ true
+
+ _
+ false))
+
+(def #export (ends-with? postfix x)
+ (-> Text Text Bool)
+ (case (last-index-of postfix x)
+ (#;Some n)
+ (i= (i+ n (size postfix))
+ (size x))
+
+ _
+ false))
+
+## [Structures]
+(defstruct #export Text/Eq (E;Eq Text)
+ (def (E;= x y)
+ (_jvm_invokevirtual java.lang.Object equals [java.lang.Object]
+ x [y])))
+
+(defstruct #export Text/Ord (O;Ord Text)
+ (def O;_eq Text/Eq)
+ (def (O;< x y)
+ (i< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String]
+ x [y]))
+ 0))
+ (def (O;<= x y)
+ (i<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String]
+ x [y]))
+ 0))
+ (def (O;> x y)
+ (i> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String]
+ x [y]))
+ 0))
+ (def (O;>= x y)
+ (i>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String]
+ x [y]))
+ 0)))
+
+(defstruct #export Text/Show (S;Show Text)
+ (def (S;show x)
+ x))
+
+(defstruct #export Text/Monoid (m;Monoid Text)
+ (def m;unit "")
+ (def (m;++ x y)
+ (_jvm_invokevirtual java.lang.String concat [java.lang.String]
+ x [y])))
diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux
new file mode 100644
index 000000000..f71492e35
--- /dev/null
+++ b/source/lux/data/writer.lux
@@ -0,0 +1,34 @@
+## 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.
+
+(;import lux
+ (lux/control (monoid #as m #refer #all)
+ (functor #as F #refer #all)
+ (monad #as M #refer #all)))
+
+## [Types]
+(deftype #export (Writer l a)
+ (, l a))
+
+## [Structures]
+(defstruct #export Writer/Functor (All [l]
+ (Functor (Writer l)))
+ (def (F;map f fa)
+ (let [[log datum] fa]
+ [log (f datum)])))
+
+(defstruct #export (Writer/Monad mon) (All [l]
+ (-> (Monoid l) (Monad (Writer l))))
+ (def M;_functor Writer/Functor)
+
+ (def (M;wrap x)
+ [(:: mon m;unit) x])
+
+ (def (M;join mma)
+ (let [[log1 [log2 a]] mma]
+ [(:: mon (m;++ log1 log2)) a])))
diff --git a/source/lux/host/java.lux b/source/lux/host/java.lux
new file mode 100644
index 000000000..12525d3f2
--- /dev/null
+++ b/source/lux/host/java.lux
@@ -0,0 +1,312 @@
+## 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.
+
+(;import lux
+ (lux (control (monoid #as m)
+ (functor #as F)
+ (monad #as M #refer (#only do)))
+ (data list
+ (text #as text))
+ (meta lux
+ macro
+ syntax)))
+
+## (open List/Functor)
+
+## [Utils/Parsers]
+(def finally^
+ (Parser Syntax)
+ (form^ (do Parser/Monad
+ [_ (symbol?^ ["" "finally"])
+ expr id^
+ _ end^]
+ (M;wrap expr))))
+
+(def catch^
+ (Parser (, Text Ident Syntax))
+ (form^ (do Parser/Monad
+ [_ (symbol?^ ["" "catch"])
+ ex-class local-symbol^
+ ex symbol^
+ expr id^
+ _ end^]
+ (M;wrap [ex-class ex expr]))))
+
+(def method-decl^
+ (Parser (, (List Text) Text (List Text) Text))
+ (form^ (do Parser/Monad
+ [modifiers (*^ local-tag^)
+ name local-symbol^
+ inputs (tuple^ (*^ local-symbol^))
+ output local-symbol^
+ _ end^]
+ (M;wrap [modifiers name inputs output]))))
+
+(def field-decl^
+ (Parser (, (List Text) Text Text))
+ (form^ (do Parser/Monad
+ [modifiers (*^ local-tag^)
+ name local-symbol^
+ class local-symbol^
+ _ end^]
+ (M;wrap [modifiers name class]))))
+
+(def arg-decl^
+ (Parser (, Text Text))
+ (form^ (do Parser/Monad
+ [arg-name local-symbol^
+ arg-class local-symbol^
+ _ end^]
+ (M;wrap [arg-name arg-class]))))
+
+(def method-def^
+ (Parser (, (List Text) Text (List (, Text Text)) Text Syntax))
+ (form^ (do Parser/Monad
+ [modifiers (*^ local-tag^)
+ name local-symbol^
+ inputs (tuple^ (*^ arg-decl^))
+ output local-symbol^
+ body id^
+ _ end^]
+ (M;wrap [modifiers name inputs output body]))))
+
+(def method-call^
+ (Parser (, Text (List Text) (List Syntax)))
+ (form^ (do Parser/Monad
+ [method local-symbol^
+ arity-classes (tuple^ (*^ local-symbol^))
+ arity-args (tuple^ (*^ id^))
+ _ end^
+ _ (: (Parser (,))
+ (if (i= (size arity-classes)
+ (size arity-args))
+ (M;wrap [])
+ (lambda [_] #;None)))]
+ (M;wrap [method arity-classes arity-args])
+ )))
+
+## [Utils/Lux]
+## (def (find-class-field field class)
+## (-> Text Text (Lux Type))
+## ...)
+
+## (def (find-virtual-method method class)
+## (-> Text Text (Lux (List (, (List Type) Type))))
+## ...)
+
+## (def (find-static-method method class)
+## (-> Text Text (Lux (List (, (List Type) Type))))
+## ...)
+
+
+## [Syntax]
+(defsyntax #export (throw ex)
+ (emit (list (` (_jvm_throw (~ ex))))))
+
+(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)])
+ (emit (list (` (_jvm_try (~ body)
+ (~@ (list:++ (:: List/Functor (F;map (: (-> (, Text Ident Syntax) Syntax)
+ (lambda [catch]
+ (let [[class ex body] catch]
+ (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body))))))
+ catches))
+ (case finally
+ #;None
+ (list)
+
+ (#;Some finally)
+ (list (` (_jvm_finally (~ finally))))))))))))
+
+(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)])
+ (do Lux/Monad
+ [current-module get-module-name
+ #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module)
+ name))]]
+ (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax)
+ (lambda [member]
+ (let [[modifiers name inputs output] member]
+ (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))])))))
+ members))]
+ (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))]
+ (~@ members'))))))))
+
+(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))]
+ [fields (*^ field-decl^)]
+ [methods (*^ method-def^)])
+ (do Lux/Monad
+ [current-module get-module-name
+ #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module)
+ name))
+ fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax)
+ (lambda [field]
+ (let [[modifiers name class] field]
+ (` ((~ (symbol$ ["" name]))
+ (~ (text$ class))
+ [(~@ (:: List/Functor (F;map text$ modifiers)))])))))
+ fields))
+ methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax)
+ (lambda [methods]
+ (let [[modifiers name inputs output body] methods]
+ (` ((~ (symbol$ ["" name]))
+ [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax)
+ (lambda [in]
+ (let [[left right] in]
+ (form$ (list (text$ left)
+ (text$ right))))))
+ inputs)))]
+ (~ (text$ output))
+ [(~@ (:: List/Functor (F;map text$ modifiers)))]
+ (~ body))))))
+ methods))]]
+ (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super))
+ [(~@ (:: List/Functor (F;map text$ interfaces)))]
+ [(~@ fields')]
+ [(~@ methods')]))))))
+
+(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))])
+ (emit (list (` (_jvm_new (~ (text$ class))
+ [(~@ (:: List/Functor (F;map text$ arg-classes)))]
+ [(~@ args)])))))
+
+(defsyntax #export (instance? [class local-symbol^] obj)
+ (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj))))))
+
+(defsyntax #export (locking lock body)
+ (do Lux/Monad
+ [g!lock (gensym "")
+ g!body (gensym "")]
+ (emit (list (` (;let [(~ g!lock) (~ lock)
+ _ (_jvm_monitor-enter (~ g!lock))
+ (~ g!body) (~ body)
+ _ (_jvm_monitor-exit (~ g!lock))]
+ (~ g!body)))))
+ ))
+
+(defsyntax #export (null? obj)
+ (emit (list (` (_jvm_null? (~ obj))))))
+
+(defsyntax #export (program [args symbol^] body)
+ (emit (list (` (_jvm_program (~ (symbol$ args))
+ (~ body))))))
+
+## (defsyntax #export (.? [field local-symbol^] obj)
+## (case obj
+## (#;Meta [_ (#;SymbolS obj-name)])
+## (do Lux/Monad
+## [obj-type (find-var-type obj-name)]
+## (case obj-type
+## (#;DataT class)
+## (do Lux/Monad
+## [field-class (find-field field class)]
+## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class))))
+
+## _
+## (fail "Can only get field from object.")))
+
+## _
+## (do Lux/Monad
+## [g!obj (gensym "")]
+## (emit (list (` (;let [(~ g!obj) (~ obj)]
+## (.? (~ field) (~ g!obj)))))))))
+
+## (defsyntax #export (.= [field local-symbol^] value obj)
+## (case obj
+## (#;Meta [_ (#;SymbolS obj-name)])
+## (do Lux/Monad
+## [obj-type (find-var-type obj-name)]
+## (case obj-type
+## (#;DataT class)
+## (do Lux/Monad
+## [field-class (find-field field class)]
+## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value)))
+
+## _
+## (fail "Can only set field of object.")))
+
+## _
+## (do Lux/Monad
+## [g!obj (gensym "")]
+## (emit (list (` (;let [(~ g!obj) (~ obj)]
+## (.= (~ field) (~ value) (~ g!obj)))))))))
+
+## (defsyntax #export (.! [call method-call^] obj)
+## (case obj
+## (#;Meta [_ (#;SymbolS obj-name)])
+## (do Lux/Monad
+## [obj-type (find-var-type obj-name)]
+## (case obj-type
+## (#;DataT class)
+## (do Lux/Monad
+## [#let [[m-name ?m-classes m-args] call]
+## all-m-details (find-virtual-method m-name class)
+## m-ins (case [?m-classes all-m-details]
+## (\ [#;None (list [m-ins m-out])])
+## (M;wrap m-ins)
+
+## (\ [(#;Some m-ins) _])
+## (M;wrap m-ins)
+
+## _
+## #;None)]
+## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))]
+## (~ obj) [(~@ m-args)])))))
+
+## _
+## (fail "Can only call method on object.")))
+
+## _
+## (do Lux/Monad
+## [g!obj (gensym "")]
+## (emit (list (` (;let [(~ g!obj) (~ obj)]
+## (.! (~@ *tokens*)))))))))
+
+## (defsyntax #export (..? [field local-symbol^] [class local-symbol^])
+## (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field)))))))
+
+## (defsyntax #export (..= [field local-symbol^] value [class local-symbol^])
+## (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value))))))
+
+## (defsyntax #export (..! [call method-call^] [class local-symbol^])
+## (do Lux/Monad
+## [#let [[m-name ?m-classes m-args] call]
+## all-m-details (find-static-method m-name class)
+## m-ins (case [?m-classes all-m-details]
+## (\ [#;None (list [m-ins m-out])])
+## (M;wrap m-ins)
+
+## (\ [(#;Some m-ins) _])
+## (M;wrap m-ins)
+
+## _
+## #;None)]
+## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class))
+## [(~@ (:: List/Functor (F;map text$ m-ins)))]
+## [(~@ m-args)]))))
+## ))
+
+## (definterface Function []
+## (#public #abstract apply [java.lang.Object] java.lang.Object))
+
+## (_jvm_interface "Function" []
+## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"]))
+
+## (defclass MyFunction [Function]
+## (#public #static foo java.lang.Object)
+## (#public <init> [] void
+## (_jvm_invokespecial java.lang.Object <init> [] this []))
+## (#public apply [(arg java.lang.Object)] java.lang.Object
+## "YOLO"))
+
+## (_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"))
diff --git a/source/lux/math.lux b/source/lux/math.lux
new file mode 100644
index 000000000..2e29c5da7
--- /dev/null
+++ b/source/lux/math.lux
@@ -0,0 +1,60 @@
+## 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.
+
+(;import lux)
+
+## [Constants]
+(do-template [<name> <value>]
+ [(def #export <name>
+ Real
+ (_jvm_getstatic java.lang.Math <value>))]
+
+ [e E]
+ [pi PI]
+ )
+
+## [Functions]
+(do-template [<name> <method>]
+ [(def #export (<name> n)
+ (-> Real Real)
+ (_jvm_invokestatic java.lang.Math <method> [double] [n]))]
+
+ [cos cos]
+ [sin sin]
+ [tan tan]
+
+ [acos acos]
+ [asin asin]
+ [atan atan]
+
+ [cosh cosh]
+ [sinh sinh]
+ [tanh tanh]
+
+ [ceil ceil]
+ [floor floor]
+ [round round]
+
+ [exp exp]
+ [log log]
+
+ [cbrt cbrt]
+ [sqrt sqrt]
+
+ [->degrees toDegrees]
+ [->radians toRadians]
+ )
+
+(do-template [<name> <method>]
+ [(def #export (<name> x y)
+ (-> Real Real Real)
+ (_jvm_invokestatic java.lang.Math <method> [double double] [x y]))]
+
+ [atan2 atan2]
+ [pow pow]
+ )
diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux
new file mode 100644
index 000000000..a28d6e5d4
--- /dev/null
+++ b/source/lux/meta/lux.lux
@@ -0,0 +1,287 @@
+## 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.
+
+(;import lux
+ (.. macro)
+ (lux/control (monoid #as m)
+ (functor #as F)
+ (monad #as M #refer (#only do)))
+ (lux/data list
+ maybe
+ (show #as S)
+ (number #as N)))
+
+## [Types]
+## (deftype (Lux a)
+## (-> Compiler (Either Text (, Compiler a))))
+
+## [Utils]
+(def (ident->text ident)
+ (-> Ident Text)
+ (let [[pre post] ident]
+ ($ text:++ pre ";" post)))
+
+## [Structures]
+(defstruct #export Lux/Functor (F;Functor Lux)
+ (def (F;map f fa)
+ (lambda [state]
+ (case (fa state)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right [state' a])
+ (#;Right [state' (f a)])))))
+
+(defstruct #export Lux/Monad (M;Monad Lux)
+ (def M;_functor Lux/Functor)
+ (def (M;wrap x)
+ (lambda [state]
+ (#;Right [state x])))
+ (def (M;join mma)
+ (lambda [state]
+ (case (mma state)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right [state' ma])
+ (ma state')))))
+
+## Functions
+(def #export (get-module-name state)
+ (Lux Text)
+ (case (reverse (get@ #;envs state))
+ #;Nil
+ (#;Left "Can't get the module name without a module!")
+
+ (#;Cons [env _])
+ (#;Right [state (get@ #;name env)])))
+
+(def (get k plist)
+ (All [a]
+ (-> Text (List (, Text a)) (Maybe a)))
+ (case plist
+ #;Nil
+ #;None
+
+ (#;Cons [[k' v] plist'])
+ (if (text:= k k')
+ (#;Some v)
+ (get k plist'))))
+
+(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 (|> (: (Module Compiler) $module) (get@ #;defs) (get name))]
+ (case (: (, Bool (DefData' Macro)) gdef)
+ [exported? (#;MacroD macro')]
+ (if (or exported? (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]
+ (: (Lux (Maybe Macro))
+ (lambda [state]
+ (#;Right [state (find-macro' (get@ #;modules state) current-module module name)]))))))
+
+(def #export (normalize ident)
+ (-> Ident (Lux Ident))
+ (case ident
+ ["" name]
+ (do Lux/Monad
+ [module-name get-module-name]
+ (M;wrap (: Ident [module-name name])))
+
+ _
+ (:: Lux/Monad (M;wrap ident))))
+
+(def #export (macro-expand syntax)
+ (-> Syntax (Lux (List Syntax)))
+ (case syntax
+ (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))])
+ (do Lux/Monad
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro macro-name')]
+ (case ?macro
+ (#;Some macro)
+ (do Lux/Monad
+ [expansion (macro args)
+ expansion' (M;map% Lux/Monad macro-expand expansion)]
+ (M;wrap (:: List/Monad (M;join expansion'))))
+
+ #;None
+ (do Lux/Monad
+ [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))]
+ (M;wrap (list (form$ (:: List/Monad (M;join parts'))))))))
+
+ (#;Meta [_ (#;FormS (#;Cons [harg targs]))])
+ (do Lux/Monad
+ [harg+ (macro-expand harg)
+ targs+ (M;map% Lux/Monad macro-expand targs)]
+ (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+))))))))
+
+ (#;Meta [_ (#;TupleS members)])
+ (do Lux/Monad
+ [members' (M;map% Lux/Monad macro-expand members)]
+ (M;wrap (list (tuple$ (:: List/Monad (M;join members'))))))
+
+ _
+ (:: Lux/Monad (M;wrap (list syntax)))))
+
+(def #export (gensym prefix state)
+ (-> Text (Lux Syntax))
+ (#;Right [(update@ #;seed inc state)
+ (symbol$ ["__gensym__" (:: N;Int/Show (S;show (get@ #;seed state)))])]))
+
+(def #export (emit datum)
+ (All [a]
+ (-> a (Lux a)))
+ (lambda [state]
+ (#;Right [state datum])))
+
+(def #export (fail msg)
+ (All [a]
+ (-> Text (Lux a)))
+ (lambda [_]
+ (#;Left msg)))
+
+(def #export (macro-expand-1 token)
+ (-> Syntax (Lux Syntax))
+ (do Lux/Monad
+ [token+ (macro-expand token)]
+ (case token+
+ (\ (list token'))
+ (M;wrap token')
+
+ _
+ (fail "Macro expanded to more than 1 element."))))
+
+(def #export (module-exists? module state)
+ (-> Text (Lux Bool))
+ (#;Right [state (case (get module (get@ #;modules state))
+ (#;Some _)
+ true
+
+ #;None
+ false)]))
+
+(def #export (exported-defs module state)
+ (-> Text (Lux (List Text)))
+ (case (get module (get@ #;modules state))
+ (#;Some =module)
+ (using List/Monad
+ (#;Right [state (M;join (:: M;_functor (F;map (: (-> (, Text (, Bool (DefData' Macro)))
+ (List Text))
+ (lambda [gdef]
+ (let [[name [export? _]] gdef]
+ (if export?
+ (list name)
+ (list)))))
+ (get@ #;defs =module))))]))
+
+ #;None
+ (#;Left ($ text:++ "Unknown module: " module))))
+
+(def (show-envs envs)
+ (-> (List (Env Text (, LuxVar Type))) Text)
+ (|> envs
+ (F;map (lambda [env]
+ (case env
+ {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _}
+ ($ text:++ name ": " (|> locals
+ (F;map (: (All [a] (-> (, Text a) Text))
+ (lambda [b] (let [[label _] b] label))))
+ (:: List/Functor)
+ (interpose " ")
+ (foldL text:++ ""))))))
+ (:: List/Functor)
+ (interpose "\n")
+ (foldL text:++ "")))
+
+(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)
+ (-> Ident Compiler (Maybe Type))
+ (let [vname' (ident->text name)]
+ (case state
+ {#;source source #;modules modules
+ #;envs envs #;types types #;host host
+ #;seed seed #;eval? eval?}
+ (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
+ (lambda [env]
+ (case env
+ {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}}
+ (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
+ (lambda [binding]
+ (let [[bname [_ type]] binding]
+ (if (text:= vname' bname)
+ (#;Some type)
+ #;None)))))
+ locals
+ closure))))
+ envs))))
+
+(def (find-in-defs name state)
+ (-> Ident Compiler (Maybe Type))
+ (let [[v-prefix v-name] name
+ {#;source source #;modules modules
+ #;envs envs #;types types #;host host
+ #;seed seed #;eval? eval?} state]
+ (case (get v-prefix modules)
+ #;None
+ #;None
+
+ (#;Some {#;defs defs #;module-aliases _ #;imports _})
+ (case (get v-name defs)
+ #;None
+ #;None
+
+ (#;Some [_ def-data])
+ (case def-data
+ #;TypeD (#;Some Type)
+ (#;ValueD type) (#;Some type)
+ (#;MacroD m) (#;Some Macro)
+ (#;AliasD name') (find-in-defs name' state))))))
+
+(def #export (find-var-type name)
+ (-> Ident (Lux Type))
+ (do Lux/Monad
+ [name' (normalize name)]
+ (: (Lux Type)
+ (lambda [state]
+ (case (find-in-env name state)
+ (#;Some struct-type)
+ (#;Right [state struct-type])
+
+ _
+ (case (find-in-defs name' state)
+ (#;Some struct-type)
+ (#;Right [state struct-type])
+
+ _
+ (let [{#;source source #;modules modules
+ #;envs envs #;types types #;host host
+ #;seed seed #;eval? eval?} state]
+ (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))
+ ))
diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux
new file mode 100644
index 000000000..22aeaf874
--- /dev/null
+++ b/source/lux/meta/macro.lux
@@ -0,0 +1,54 @@
+## 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.
+
+(;import lux)
+
+## [Utils]
+(def (_meta x)
+ (-> (Syntax' (Meta Cursor)) Syntax)
+ (#;Meta [["" -1 -1] x]))
+
+## [Syntax]
+(def #export (defmacro tokens state)
+ Macro
+ (case tokens
+ (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])
+ (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args))
+ (~ (_meta (#;SymbolS ["lux" "Macro"])))
+ (~ body)))
+ (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name)))
+ #;Nil])])])
+
+ (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])])
+ (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args))
+ (~ (_meta (#;SymbolS ["lux" "Macro"])))
+ (~ body)))
+ (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name)))
+ #;Nil])])])
+
+ _
+ (#;Left "Wrong syntax for defmacro")))
+(_lux_declare-macro defmacro)
+
+## [Functions]
+(do-template [<name> <type> <tag>]
+ [(def #export (<name> x)
+ (-> <type> Syntax)
+ (#;Meta [["" -1 -1] (<tag> x)]))]
+
+ [bool$ Bool #;BoolS]
+ [int$ Int #;IntS]
+ [real$ Real #;RealS]
+ [char$ Char #;CharS]
+ [text$ Text #;TextS]
+ [symbol$ Ident #;SymbolS]
+ [tag$ Ident #;TagS]
+ [form$ (List Syntax) #;FormS]
+ [tuple$ (List Syntax) #;TupleS]
+ [record$ (List (, Syntax Syntax)) #;RecordS]
+ )
diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux
new file mode 100644
index 000000000..1fe85c32f
--- /dev/null
+++ b/source/lux/meta/syntax.lux
@@ -0,0 +1,262 @@
+## 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.
+
+(;import lux
+ (.. (macro #as m #refer #all)
+ (lux #as l #refer (#only Lux/Monad gensym)))
+ (lux (control (functor #as F)
+ (monad #as M #refer (#only do)))
+ (data (eq #as E)
+ (bool #as b)
+ (char #as c)
+ (text #as t)
+ list)))
+
+## [Utils]
+(def (first xy)
+ (All [a b] (-> (, a b) a))
+ (let [[x y] xy]
+ x))
+
+(def (join-pairs pairs)
+ (All [a] (-> (List (, a a)) (List a)))
+ (case pairs
+ #;Nil #;Nil
+ (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs'))))
+
+## Types
+(deftype #export (Parser a)
+ (-> (List Syntax) (Maybe (, (List Syntax) a))))
+
+## Structures
+(defstruct #export Parser/Functor (F;Functor Parser)
+ (def (F;map f ma)
+ (lambda [tokens]
+ (case (ma tokens)
+ #;None
+ #;None
+
+ (#;Some [tokens' a])
+ (#;Some [tokens' (f a)])))))
+
+(defstruct #export Parser/Monad (M;Monad Parser)
+ (def M;_functor Parser/Functor)
+
+ (def (M;wrap x tokens)
+ (#;Some [tokens x]))
+
+ (def (M;join mma)
+ (lambda [tokens]
+ (case (mma tokens)
+ #;None
+ #;None
+
+ (#;Some [tokens' ma])
+ (ma tokens')))))
+
+## Parsers
+(def #export (id^ tokens)
+ (Parser Syntax)
+ (case tokens
+ #;Nil #;None
+ (#;Cons [t tokens']) (#;Some [tokens' t])))
+
+(do-template [<name> <type> <tag>]
+ [(def #export (<name> tokens)
+ (Parser <type>)
+ (case tokens
+ (#;Cons [(#;Meta [_ (<tag> x)]) tokens'])
+ (#;Some [tokens' x])
+
+ _
+ #;None))]
+
+ [ bool^ Bool #;BoolS]
+ [ int^ Int #;IntS]
+ [ real^ Real #;RealS]
+ [ char^ Char #;CharS]
+ [ text^ Text #;TextS]
+ [symbol^ Ident #;SymbolS]
+ [ tag^ Ident #;TagS]
+ )
+
+(do-template [<name> <tag>]
+ [(def #export (<name> tokens)
+ (Parser Text)
+ (case tokens
+ (#;Cons [(#;Meta [_ (<tag> ["" x])]) tokens'])
+ (#;Some [tokens' x])
+
+ _
+ #;None))]
+
+ [local-symbol^ #;SymbolS]
+ [ local-tag^ #;TagS]
+ )
+
+(def (ident:= x y)
+ (-> Ident Ident Bool)
+ (let [[x1 x2] x
+ [y1 y2] y]
+ (and (text:= x1 y1)
+ (text:= x2 y2))))
+
+(do-template [<name> <type> <tag> <eq>]
+ [(def #export (<name> v tokens)
+ (-> <type> (Parser (,)))
+ (case tokens
+ (#;Cons [(#;Meta [_ (<tag> x)]) tokens'])
+ (if (<eq> v x)
+ (#;Some [tokens' []])
+ #;None)
+
+ _
+ #;None))]
+
+ [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)]
+ [ int?^ Int #;IntS i=]
+ [ real?^ Real #;RealS r=]
+ [ char?^ Char #;CharS (:: c;Char/Eq E;=)]
+ [ text?^ Text #;TextS (:: t;Text/Eq E;=)]
+ [symbol?^ Ident #;SymbolS ident:=]
+ [ tag?^ Ident #;TagS ident:=]
+ )
+
+(do-template [<name> <tag>]
+ [(def #export (<name> p tokens)
+ (All [a]
+ (-> (Parser a) (Parser a)))
+ (case tokens
+ (#;Cons [(#;Meta [_ (<tag> form)]) tokens'])
+ (case (p form)
+ (#;Some [#;Nil x]) (#;Some [tokens' x])
+ _ #;None)
+
+ _
+ #;None))]
+
+ [ form^ #;FormS]
+ [tuple^ #;TupleS]
+ )
+
+(def #export (?^ p tokens)
+ (All [a]
+ (-> (Parser a) (Parser (Maybe a))))
+ (case (p tokens)
+ #;None (#;Some [tokens #;None])
+ (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)])))
+
+(def (run-parser p tokens)
+ (All [a]
+ (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a))))
+ (p tokens))
+
+(def #export (*^ p tokens)
+ (All [a]
+ (-> (Parser a) (Parser (List a))))
+ (case (p tokens)
+ #;None (#;Some [tokens (list)])
+ (#;Some [tokens' x]) (run-parser (do Parser/Monad
+ [xs (*^ p)]
+ (M;wrap (list& x xs)))
+ tokens')))
+
+(def #export (+^ p)
+ (All [a]
+ (-> (Parser a) (Parser (List a))))
+ (do Parser/Monad
+ [x p
+ xs (*^ p)]
+ (M;wrap (list& x xs))))
+
+(def #export (&^ p1 p2)
+ (All [a b]
+ (-> (Parser a) (Parser b) (Parser (, a b))))
+ (do Parser/Monad
+ [x1 p1
+ x2 p2]
+ (M;wrap [x1 x2])))
+
+(def #export (|^ p1 p2 tokens)
+ (All [a b]
+ (-> (Parser a) (Parser b) (Parser (Either b))))
+ (case (p1 tokens)
+ (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)])
+ #;None (run-parser (do Parser/Monad
+ [x2 p2]
+ (M;wrap (#;Right x2)))
+ tokens)))
+
+(def #export (||^ ps tokens)
+ (All [a]
+ (-> (List (Parser a)) (Parser (Maybe a))))
+ (case ps
+ #;Nil #;None
+ (#;Cons [p ps']) (case (p tokens)
+ #;None (||^ ps' tokens)
+ (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)]))
+ ))
+
+(def #export (end^ tokens)
+ (Parser (,))
+ (case tokens
+ #;Nil (#;Some [tokens []])
+ _ #;None))
+
+## Syntax
+(defmacro #export (defsyntax tokens)
+ (let [[exported? tokens] (: (, Bool (List Syntax))
+ (case tokens
+ (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens'))
+ [true tokens']
+
+ _
+ [false tokens]))]
+ (case tokens
+ (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))])
+ body))
+ (do Lux/Monad
+ [names+parsers (M;map% Lux/Monad
+ (: (-> Syntax (Lux (, Syntax Syntax)))
+ (lambda [arg]
+ (case arg
+ (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)])
+ parser))]))
+ (M;wrap [(symbol$ var-name) parser])
+
+ (\ (#;Meta [_ (#;SymbolS var-name)]))
+ (M;wrap [(symbol$ var-name) (` id^)])
+
+ _
+ (l;fail "Syntax pattern expects 2-tuples or symbols."))))
+ args)
+ g!tokens (gensym "tokens")
+ g!_ (gensym "_")
+ #let [names (:: List/Functor (F;map first names+parsers))
+ error-msg (text$ (text:++ "Wrong syntax for " name))
+ body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+ (lambda [body name+parser]
+ (let [[name parser] name+parser]
+ (` (_lux_case ((~ parser) (~ g!tokens))
+ (#;Some [(~ g!tokens) (~ name)])
+ (~ body)
+
+ (~ g!_)
+ (l;fail (~ error-msg)))))))
+ body
+ (reverse names+parsers))
+ macro-def (: Syntax
+ (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens))
+ (~ body'))))]]
+ (M;wrap (list& macro-def
+ (if exported?
+ (list (` (_lux_export (~ (symbol$ ["" name])))))
+ (list)))))
+
+ _
+ (l;fail "Wrong syntax for defsyntax"))))
diff --git a/source/program.lux b/source/program.lux
new file mode 100644
index 000000000..052c0bf41
--- /dev/null
+++ b/source/program.lux
@@ -0,0 +1,48 @@
+## 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.
+
+(;import lux
+ (lux (codata (stream #as S))
+ (control monoid
+ functor
+ monad
+ lazy
+ comonad)
+ (data bool
+ bounded
+ char
+ ## cont
+ dict
+ (either #as e)
+ eq
+ error
+ id
+ io
+ list
+ maybe
+ number
+ ord
+ (reader #as r)
+ show
+ state
+ (text #as t)
+ writer)
+ (host java)
+ (meta lux
+ macro
+ syntax)
+ (math #as m)
+ ))
+
+(program args
+ (case args
+ #;Nil
+ (println "Hello, world!")
+
+ (#;Cons [name _])
+ (println ($ text:++ "Hello, " name "!"))))
diff --git a/src/lux.clj b/src/lux.clj
index 7ff8fda37..9c913c9ac 100644
--- a/src/lux.clj
+++ b/src/lux.clj
@@ -14,9 +14,7 @@
:reload-all))
(defn -main [& _]
- (do (time (&compiler/compile-all (&/|list "lux" "program")))
- ;; (prn @&type/counter)
- )
+ (time (&compiler/compile-all (&/|list "lux" "program")))
(System/exit 0))
(comment
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index 68bd627fc..e490bc62f 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -117,9 +117,9 @@
(defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args]
(|do [=classes (&/map% &host/extract-jvm-param ?classes)
=return (&host/lookup-static-method ?class ?method =classes)
- :let [_ (matchv ::M/objects [=return]
- [["lux;DataT" _return-class]]
- (prn 'analyse-jvm-invokestatic ?class ?method _return-class))]
+ ;; :let [_ (matchv ::M/objects [=return]
+ ;; [["lux;DataT" _return-class]]
+ ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))]
=args (&/map2% (fn [_class _arg]
(&&/analyse-1 analyse (&/V "lux;DataT" _class) _arg))
=classes
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 6acae193f..b25dff9eb 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -394,7 +394,7 @@
(return nil))]
(&/save-module
(|do [already-compiled? (&&module/exists? ?path)
- :let [_ (prn 'analyse-import module-name ?path already-compiled?)]
+ ;; :let [_ (prn 'analyse-import module-name ?path already-compiled?)]
_ (&&module/add-import ?path)
_ (&/when% (not already-compiled?) (compile-module ?path))]
(return (&/|list))))))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 05ab12bf1..bb1c72f66 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -24,6 +24,7 @@
[lux.analyser.base :as &a]
[lux.analyser.module :as &a-module]
(lux.compiler [base :as &&]
+ [cache :as &&cache]
[lux :as &&lux]
[host :as &&host]
[case :as &&case]
@@ -369,12 +370,12 @@
return))))
(defn ^:private compile-module [name]
- ;; (prn 'compile-module name (&&/cached? name))
- (let [file-name (str "input/" name ".lux")
+ ;; (prn 'compile-module name (&&cache/cached? name))
+ (let [file-name (str &&/input-dir "/" name ".lux")
file-content (slurp file-name)
file-hash (hash file-content)]
- (if (&&/cached? name)
- (&&/load-cache name file-hash compile-module)
+ (if (&&cache/cached? name)
+ (&&cache/load name file-hash compile-module)
(let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)]
(&/map% compile-statement analysis+))]
(|do [module-exists? (&a-module/exists? name)]
@@ -416,31 +417,16 @@
(fail* ?message)))))))
)))
-(defn ^:private clean-file [^java.io.File file]
- (if (.isDirectory file)
- (do (doseq [f (seq (.listFiles file))]
- (clean-file f))
- (.delete file))
- (.delete file)))
-
-(defn ^:private setup-dirs! []
- (.mkdir (java.io.File. "cache"))
- (.mkdir (java.io.File. "cache/jvm"))
- (.mkdir (java.io.File. "output"))
- (.mkdir (java.io.File. "output/jvm"))
- (doseq [f (seq (.listFiles (java.io.File. "output/jvm")))]
- (clean-file f)))
+(defn ^:private init! []
+ (.mkdirs (java.io.File. &&/output-dir)))
;; [Resources]
(defn compile-all [modules]
- (setup-dirs!)
+ (init!)
(matchv ::M/objects [((&/map% compile-module modules) (&/init-state nil))]
[["lux;Right" [?state _]]]
- (println "Compilation complete!")
+ (do (println "Compilation complete!")
+ (&&cache/clean ?state))
[["lux;Left" ?message]]
(assert false ?message)))
-
-(comment
- (compile-all ["lux"])
- )
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index d3dfc8746..e7b338b16 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -25,43 +25,28 @@
FileOutputStream)
(java.lang.reflect Field)))
+;; [Constants]
+(def ^String version "0.2")
+(def ^String input-dir "source")
+(def ^String output-dir "target/jvm")
+
+(def ^String local-prefix "l")
+(def ^String partial-prefix "p")
+(def ^String closure-prefix "c")
+(def ^String apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;")
+
;; [Utils]
(defn ^:private write-file [^String file ^bytes data]
(with-open [stream (BufferedOutputStream. (FileOutputStream. file))]
(.write stream data)))
(defn ^:private write-output [module name data]
- (let [module* (&host/->module-class module)]
- (.mkdirs (File. (str "output/jvm/" module*)))
- (write-file (str "output/jvm/" module* "/" name ".class") data)))
-
-(defn ^:private write-cache [module name data]
- (let [module* (&host/->module-class module)]
- (.mkdirs (File. (str "cache/jvm/" module*)))
- (write-file (str "cache/jvm/" module* "/" name ".class") data)))
-
-(defn ^:private clean-file [^File file]
- (if (.isDirectory file)
- (do (doseq [f (seq (.listFiles file))]
- (clean-file f))
- (.delete file))
- (.delete file)))
-
-(defn ^:private read-file [^File file]
- (with-open [reader (io/input-stream file)]
- (let [length (.length file)
- buffer (byte-array length)]
- (.read reader buffer 0 length)
- buffer)))
+ (let [module* (&host/->module-class module)
+ module-dir (str output-dir "/" module*)]
+ (.mkdirs (File. module-dir))
+ (write-file (str module-dir "/" name ".class") data)))
;; [Exports]
-(def version "0.2")
-
-(def local-prefix "l")
-(def partial-prefix "p")
-(def closure-prefix "c")
-(def apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;")
-
(defn load-class! [^ClassLoader loader name]
;; (prn 'load-class! name)
(.loadClass loader name))
@@ -75,104 +60,5 @@
_ (swap! !classes assoc real-name bytecode)
_ (load-class! loader real-name)
_ (when (not eval?)
- (do (write-output module name bytecode)
- (write-cache module name bytecode)))]]
+ (write-output module name bytecode))]]
(return nil)))
-
-(defn cached? [module]
- (.exists (File. (str "cache/jvm/" (&host/->module-class module) "/_.class"))))
-
-(defn delete-cache [module]
- (fn [state]
- (do (clean-file (File. (str "cache/jvm/" (&host/->module-class module))))
- (return* state nil))))
-
-(defn ^:private replace-several [content & replacements]
- (let [replacement-list (partition 2 replacements)]
- (reduce #(try (let [[_pattern _rep] %2]
- (string/replace %1 _pattern (string/re-quote-replacement _rep)))
- (catch Exception e
- (prn 'replace-several content %1 %2)
- (throw e)))
- content replacement-list)))
-
-(defn ^:private get-field [^String field-name ^Class class]
- (-> class ^Field (.getField field-name) (.get nil))
- ;; (try (-> class ^Field (.getField field-name) (.get nil))
- ;; (catch Error e
- ;; (assert false (prn-str 'get-field field-name class))))
- )
-
-(defn load-cache [module module-hash compile-module]
- (|do [loader &/loader
- !classes &/classes
- already-loaded? (&a-module/exists? module)
- _modules &/modules
- :let [redo-cache (|do [_ (delete-cache module)
- _ (compile-module module)]
- (return false))]]
- (do (prn 'load-cache module 'sources already-loaded?
- (&/->seq _modules))
- (if already-loaded?
- (return true)
- (if (cached? module)
- (do (prn 'load-cache/HASH module module-hash)
- (let [module* (&host/->module-class module)
- module-path (str "cache/jvm/" module*)
- class-name (str module* "._")
- ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class"))))
- (load-class! loader class-name))]
- (if (and (= module-hash (get-field "_hash" module-meta))
- (= version (get-field "_compiler" module-meta)))
- (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t")
- _ (prn 'load-cache/IMPORTS module imports)
- ]
- (|do [loads (&/map% (fn [_import]
- (load-cache _import (-> (str "input/" _import ".lux") slurp hash) compile-module))
- (if (= [""] imports)
- (&/|list)
- (&/->list imports)))]
- (if (->> loads &/->seq (every? true?))
- (do (doseq [^File file (seq (.listFiles (File. module-path)))
- :let [file-name (.getName file)]
- :when (not= "_.class" file-name)]
- (let [real-name (second (re-find #"^(.*)\.class$" file-name))
- bytecode (read-file file)
- ;; _ (prn 'load-cache module real-name)
- ]
- (swap! !classes assoc (str module* "." real-name) bytecode)
- (write-output module real-name bytecode)))
- (let [defs (string/split (get-field "_defs" module-meta) #"\t")]
- ;; (prn 'load-cache module defs)
- (|do [_ (&a-module/enter-module module)
- _ (&/map% (fn [_def]
- (let [[_exported? _name _ann] (string/split _def #" ")
- ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann])
- ]
- (|do [_ (case _ann
- "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type)
- "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)]
- (&a-module/declare-macro module _name))
- "V" (let [def-class (load-class! loader (str module* "." (&/normalize-name _name)))
- ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class)
- def-type (get-field "_meta" def-class)]
- (matchv ::M/objects [def-type]
- [["lux;ValueD" _def-type]]
- (&a-module/define module _name def-type _def-type)))
- ;; else
- (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)]
- (|do [__type (&a-module/def-type __module __name)]
- (do ;; (prn '__type [__module __name] (&type/show-type __type))
- (&a-module/def-alias module _name __module __name __type)))))]
- (if (= "1" _exported?)
- (&a-module/export module _name)
- (return nil)))
- ))
- (if (= [""] defs)
- (&/|list)
- (&/->list defs)))]
- (return true))))
- redo-cache)))
- redo-cache)
- ))
- redo-cache)))))
diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj
new file mode 100644
index 000000000..d6f0b1db7
--- /dev/null
+++ b/src/lux/compiler/cache.clj
@@ -0,0 +1,135 @@
+;; 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.
+
+(ns lux.compiler.cache
+ (:refer-clojure :exclude [load])
+ (:require [clojure.string :as string]
+ [clojure.java.io :as io]
+ [clojure.core.match :as M :refer [matchv]]
+ clojure.core.match.array
+ (lux [base :as & :refer [|do return* return fail fail*]]
+ [type :as &type]
+ [host :as &host])
+ (lux.analyser [base :as &a]
+ [module :as &a-module])
+ (lux.compiler [base :as &&]))
+ (:import (java.io File
+ BufferedOutputStream
+ FileOutputStream)
+ (java.lang.reflect Field)))
+
+;; [Utils]
+(defn ^:private read-file [^File file]
+ (with-open [reader (io/input-stream file)]
+ (let [length (.length file)
+ buffer (byte-array length)]
+ (.read reader buffer 0 length)
+ buffer)))
+
+(defn ^:private clean-file [^File file]
+ (if (.isDirectory file)
+ (do (doseq [f (seq (.listFiles file))]
+ (clean-file f))
+ (.delete file))
+ (.delete file)))
+
+(defn ^:private get-field [^String field-name ^Class class]
+ (-> class ^Field (.getField field-name) (.get nil)))
+
+;; [Resources]
+(defn cached? [module]
+ "(-> Text Bool)"
+ (.exists (new File (str &&/output-dir "/" (&host/->module-class module) "/_.class"))))
+
+(defn delete [module]
+ "(-> Text (Lux (,)))"
+ (fn [state]
+ (do (clean-file (new File (str &&/output-dir "/" (&host/->module-class module))))
+ (return* state nil))))
+
+(defn clean [state]
+ "(-> Compiler (,))"
+ (let [needed-modules (->> state (&/get$ &/$MODULES) &/|keys &/->seq set)
+ outdated? #(-> % .getName (string/replace " " "/") (->> (contains? needed-modules)) not)
+ outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?))]
+ (doseq [f outdate-files]
+ (clean-file f))
+ nil))
+
+(defn load [module module-hash compile-module]
+ (|do [loader &/loader
+ !classes &/classes
+ already-loaded? (&a-module/exists? module)
+ _modules &/modules
+ :let [redo-cache (|do [_ (delete module)
+ _ (compile-module module)]
+ (return false))]]
+ (do ;; (prn 'load module 'sources already-loaded?
+ ;; (&/->seq _modules))
+ (if already-loaded?
+ (return true)
+ (if (cached? module)
+ (do ;; (prn 'load/HASH module module-hash)
+ (let [module* (&host/->module-class module)
+ module-path (str &&/output-dir "/" module*)
+ class-name (str module* "._")
+ ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class"))))
+ (&&/load-class! loader class-name))]
+ (if (and (= module-hash (get-field "_hash" module-meta))
+ (= &&/version (get-field "_compiler" module-meta)))
+ (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t")
+ ;; _ (prn 'load/IMPORTS module imports)
+ ]
+ (|do [loads (&/map% (fn [_import]
+ (load _import (-> (str &&/input-dir "/" _import ".lux") slurp hash) compile-module))
+ (if (= [""] imports)
+ (&/|list)
+ (&/->list imports)))]
+ (if (->> loads &/->seq (every? true?))
+ (do (doseq [^File file (seq (.listFiles (File. module-path)))
+ :let [file-name (.getName file)]
+ :when (not= "_.class" file-name)]
+ (let [real-name (second (re-find #"^(.*)\.class$" file-name))
+ bytecode (read-file file)
+ ;; _ (prn 'load module real-name)
+ ]
+ (swap! !classes assoc (str module* "." real-name) bytecode)))
+ (let [defs (string/split (get-field "_defs" module-meta) #"\t")]
+ ;; (prn 'load module defs)
+ (|do [_ (&a-module/enter-module module)
+ _ (&/map% (fn [_def]
+ (let [[_exported? _name _ann] (string/split _def #" ")
+ ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann])
+ ]
+ (|do [_ (case _ann
+ "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type)
+ "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)]
+ (&a-module/declare-macro module _name))
+ "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name)))
+ ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class)
+ def-type (get-field "_meta" def-class)]
+ (matchv ::M/objects [def-type]
+ [["lux;ValueD" _def-type]]
+ (&a-module/define module _name def-type _def-type)))
+ ;; else
+ (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)]
+ (|do [__type (&a-module/def-type __module __name)]
+ (do ;; (prn '__type [__module __name] (&type/show-type __type))
+ (&a-module/def-alias module _name __module __name __type)))))]
+ (if (= "1" _exported?)
+ (&a-module/export module _name)
+ (return nil)))
+ ))
+ (if (= [""] defs)
+ (&/|list)
+ (&/->list defs)))]
+ (return true))))
+ redo-cache)))
+ redo-cache)
+ ))
+ redo-cache)))))
--
cgit v1.2.3