From 7f66c54f4c9753b94dbf46ec50b8b16549daf324 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 1 Dec 2016 11:00:44 -0400 Subject: - Collected the Lux compiler's repo, the Standard Library's, the Leiningen plugin's and the Emacs mode's into a big monorepo, to keep development unified. --- .gitignore | 11 +- code_of_conduct.md | 22 - license.txt | 374 -- lux-lein/LICENSE | 214 + lux-lein/README.md | 27 + lux-lein/license.txt | 374 ++ lux-lein/project.clj | 21 + lux-lein/src/leiningen/luxc.clj | 27 + lux-lein/src/leiningen/luxc/compiler.clj | 19 + lux-lein/src/leiningen/luxc/packager.clj | 212 + lux-lein/src/leiningen/luxc/repl.clj | 35 + lux-lein/src/leiningen/luxc/test.clj | 27 + lux-lein/src/leiningen/luxc/utils.clj | 97 + lux-mode/README.md | 16 + lux-mode/lux-mode.el | 398 ++ luxc/code_of_conduct.md | 22 + luxc/license.txt | 374 ++ luxc/project.clj | 30 + luxc/src/lux.clj | 52 + luxc/src/lux/analyser.clj | 211 + luxc/src/lux/analyser/base.clj | 131 + luxc/src/lux/analyser/case.clj | 654 +++ luxc/src/lux/analyser/env.clj | 74 + luxc/src/lux/analyser/host.clj | 1379 ++++++ luxc/src/lux/analyser/lambda.clj | 33 + luxc/src/lux/analyser/lux.clj | 736 ++++ luxc/src/lux/analyser/meta.clj | 46 + luxc/src/lux/analyser/module.clj | 403 ++ luxc/src/lux/analyser/parser.clj | 469 +++ luxc/src/lux/analyser/record.clj | 47 + luxc/src/lux/base.clj | 1449 +++++++ luxc/src/lux/compiler.clj | 268 ++ luxc/src/lux/compiler/base.clj | 116 + luxc/src/lux/compiler/cache.clj | 188 + luxc/src/lux/compiler/cache/ann.clj | 159 + luxc/src/lux/compiler/cache/type.clj | 164 + luxc/src/lux/compiler/case.clj | 219 + luxc/src/lux/compiler/host.clj | 2514 +++++++++++ luxc/src/lux/compiler/io.clj | 36 + luxc/src/lux/compiler/lambda.clj | 286 ++ luxc/src/lux/compiler/lux.clj | 498 +++ luxc/src/lux/compiler/module.clj | 28 + luxc/src/lux/compiler/parallel.clj | 47 + luxc/src/lux/host.clj | 432 ++ luxc/src/lux/host/generics.clj | 205 + luxc/src/lux/lexer.clj | 254 ++ luxc/src/lux/lib/loader.clj | 54 + luxc/src/lux/optimizer.clj | 1202 ++++++ luxc/src/lux/parser.clj | 117 + luxc/src/lux/reader.clj | 141 + luxc/src/lux/repl.clj | 89 + luxc/src/lux/type.clj | 972 +++++ luxc/src/lux/type/host.clj | 352 ++ luxc/test/test/lux/lexer.clj | 276 ++ luxc/test/test/lux/parser.clj | 274 ++ luxc/test/test/lux/reader.clj | 53 + luxc/test/test/lux/type.clj | 473 +++ project.clj | 30 - src/lux.clj | 38 - src/lux/analyser.clj | 211 - src/lux/analyser/base.clj | 131 - src/lux/analyser/case.clj | 654 --- src/lux/analyser/env.clj | 74 - src/lux/analyser/host.clj | 1379 ------ src/lux/analyser/lambda.clj | 33 - src/lux/analyser/lux.clj | 736 ---- src/lux/analyser/meta.clj | 46 - src/lux/analyser/module.clj | 403 -- src/lux/analyser/parser.clj | 469 --- src/lux/analyser/record.clj | 47 - src/lux/base.clj | 1449 ------- src/lux/compiler.clj | 268 -- src/lux/compiler/base.clj | 116 - src/lux/compiler/cache.clj | 188 - src/lux/compiler/cache/ann.clj | 159 - src/lux/compiler/cache/type.clj | 164 - src/lux/compiler/case.clj | 219 - src/lux/compiler/host.clj | 2514 ----------- src/lux/compiler/io.clj | 36 - src/lux/compiler/lambda.clj | 286 -- src/lux/compiler/lux.clj | 498 --- src/lux/compiler/module.clj | 28 - src/lux/compiler/parallel.clj | 47 - src/lux/host.clj | 432 -- src/lux/host/generics.clj | 205 - src/lux/lexer.clj | 254 -- src/lux/lib/loader.clj | 54 - src/lux/optimizer.clj | 1202 ------ src/lux/parser.clj | 117 - src/lux/reader.clj | 141 - src/lux/repl.clj | 89 - src/lux/type.clj | 972 ----- src/lux/type/host.clj | 352 -- stdlib/README.md | 15 + stdlib/license.txt | 374 ++ stdlib/project.clj | 19 + stdlib/source/lux.lux | 5541 +++++++++++++++++++++++++ stdlib/source/lux/cli.lux | 271 ++ stdlib/source/lux/codata/cont.lux | 64 + stdlib/source/lux/codata/env.lux | 65 + stdlib/source/lux/codata/function.lux | 23 + stdlib/source/lux/codata/io.lux | 56 + stdlib/source/lux/codata/state.lux | 114 + stdlib/source/lux/codata/struct/stream.lux | 135 + stdlib/source/lux/compiler.lux | 559 +++ stdlib/source/lux/concurrency/actor.lux | 278 ++ stdlib/source/lux/concurrency/atom.lux | 41 + stdlib/source/lux/concurrency/frp.lux | 194 + stdlib/source/lux/concurrency/promise.lux | 233 ++ stdlib/source/lux/concurrency/stm.lux | 237 ++ stdlib/source/lux/control/applicative.lux | 33 + stdlib/source/lux/control/bounded.lux | 14 + stdlib/source/lux/control/codec.lux | 28 + stdlib/source/lux/control/comonad.lux | 54 + stdlib/source/lux/control/effect.lux | 315 ++ stdlib/source/lux/control/enum.lux | 24 + stdlib/source/lux/control/eq.lux | 29 + stdlib/source/lux/control/fold.lux | 12 + stdlib/source/lux/control/functor.lux | 16 + stdlib/source/lux/control/hash.lux | 15 + stdlib/source/lux/control/monad.lux | 142 + stdlib/source/lux/control/monoid.lux | 13 + stdlib/source/lux/control/number.lux | 22 + stdlib/source/lux/control/ord.lux | 44 + stdlib/source/lux/data/bit.lux | 66 + stdlib/source/lux/data/bool.lux | 47 + stdlib/source/lux/data/char.lux | 107 + stdlib/source/lux/data/error.lux | 66 + stdlib/source/lux/data/error/exception.lux | 62 + stdlib/source/lux/data/format/json.lux | 1031 +++++ stdlib/source/lux/data/ident.lux | 57 + stdlib/source/lux/data/identity.lux | 37 + stdlib/source/lux/data/log.lux | 62 + stdlib/source/lux/data/maybe.lux | 82 + stdlib/source/lux/data/number.lux | 222 + stdlib/source/lux/data/product.lux | 35 + stdlib/source/lux/data/struct/array.lux | 224 + stdlib/source/lux/data/struct/dict.lux | 675 +++ stdlib/source/lux/data/struct/list.lux | 487 +++ stdlib/source/lux/data/struct/queue.lux | 79 + stdlib/source/lux/data/struct/set.lux | 85 + stdlib/source/lux/data/struct/stack.lux | 47 + stdlib/source/lux/data/struct/tree.lux | 54 + stdlib/source/lux/data/struct/vector.lux | 428 ++ stdlib/source/lux/data/struct/zipper.lux | 196 + stdlib/source/lux/data/sum.lux | 45 + stdlib/source/lux/data/text.lux | 223 + stdlib/source/lux/data/text/format.lux | 54 + stdlib/source/lux/host.lux | 2137 ++++++++++ stdlib/source/lux/lexer.lux | 439 ++ stdlib/source/lux/macro.lux | 31 + stdlib/source/lux/macro/ast.lux | 149 + stdlib/source/lux/macro/poly.lux | 364 ++ stdlib/source/lux/macro/poly/eq.lux | 103 + stdlib/source/lux/macro/poly/functor.lux | 126 + stdlib/source/lux/macro/poly/text-encoder.lux | 126 + stdlib/source/lux/macro/syntax.lux | 472 +++ stdlib/source/lux/macro/syntax/common.lux | 164 + stdlib/source/lux/macro/template.lux | 54 + stdlib/source/lux/math.lux | 158 + stdlib/source/lux/math/complex.lux | 291 ++ stdlib/source/lux/math/random.lux | 283 ++ stdlib/source/lux/math/ratio.lux | 141 + stdlib/source/lux/pipe.lux | 147 + stdlib/source/lux/regex.lux | 432 ++ stdlib/source/lux/test.lux | 330 ++ stdlib/source/lux/type.lux | 275 ++ stdlib/source/lux/type/auto.lux | 211 + stdlib/source/lux/type/check.lux | 518 +++ stdlib/test/test/lux.lux | 164 + stdlib/test/test/lux/cli.lux | 84 + stdlib/test/test/lux/codata/env.lux | 23 + stdlib/test/test/lux/codata/io.lux | 21 + stdlib/test/test/lux/codata/state.lux | 34 + stdlib/test/test/lux/codata/struct/stream.lux | 68 + stdlib/test/test/lux/concurrency/actor.lux | 70 + stdlib/test/test/lux/concurrency/frp.lux | 54 + stdlib/test/test/lux/concurrency/promise.lux | 31 + stdlib/test/test/lux/concurrency/stm.lux | 57 + stdlib/test/test/lux/data/bit.lux | 65 + stdlib/test/test/lux/data/bool.lux | 38 + stdlib/test/test/lux/data/char.lux | 47 + stdlib/test/test/lux/data/error.lux | 42 + stdlib/test/test/lux/data/format/json.lux | 314 ++ stdlib/test/test/lux/data/ident.lux | 53 + stdlib/test/test/lux/data/identity.lux | 36 + stdlib/test/test/lux/data/log.lux | 32 + stdlib/test/test/lux/data/maybe.lux | 49 + stdlib/test/test/lux/data/number.lux | 135 + stdlib/test/test/lux/data/product.lux | 20 + stdlib/test/test/lux/data/struct/array.lux | 130 + stdlib/test/test/lux/data/struct/dict.lux | 136 + stdlib/test/test/lux/data/struct/list.lux | 191 + stdlib/test/test/lux/data/struct/queue.lux | 54 + stdlib/test/test/lux/data/struct/set.lux | 67 + stdlib/test/test/lux/data/struct/stack.lux | 47 + stdlib/test/test/lux/data/struct/tree.lux | 39 + stdlib/test/test/lux/data/struct/vector.lux | 84 + stdlib/test/test/lux/data/struct/zipper.lux | 127 + stdlib/test/test/lux/data/sum.lux | 32 + stdlib/test/test/lux/data/text.lux | 150 + stdlib/test/test/lux/data/text/format.lux | 22 + stdlib/test/test/lux/host.lux | 54 + stdlib/test/test/lux/lexer.lux | 133 + stdlib/test/test/lux/macro/ast.lux | 31 + stdlib/test/test/lux/macro/syntax.lux | 176 + stdlib/test/test/lux/math.lux | 45 + stdlib/test/test/lux/pipe.lux | 47 + stdlib/test/test/lux/regex.lux | 200 + stdlib/test/test/lux/type.lux | 41 + stdlib/test/tests.lux | 84 + test/test/lux/lexer.clj | 276 -- test/test/lux/parser.clj | 274 -- test/test/lux/reader.clj | 53 - test/test/lux/type.clj | 473 --- 215 files changed, 40727 insertions(+), 15520 deletions(-) delete mode 100644 code_of_conduct.md delete mode 100644 license.txt create mode 100644 lux-lein/LICENSE create mode 100644 lux-lein/README.md create mode 100644 lux-lein/license.txt create mode 100644 lux-lein/project.clj create mode 100644 lux-lein/src/leiningen/luxc.clj create mode 100644 lux-lein/src/leiningen/luxc/compiler.clj create mode 100644 lux-lein/src/leiningen/luxc/packager.clj create mode 100644 lux-lein/src/leiningen/luxc/repl.clj create mode 100644 lux-lein/src/leiningen/luxc/test.clj create mode 100644 lux-lein/src/leiningen/luxc/utils.clj create mode 100644 lux-mode/README.md create mode 100644 lux-mode/lux-mode.el create mode 100644 luxc/code_of_conduct.md create mode 100644 luxc/license.txt create mode 100644 luxc/project.clj create mode 100644 luxc/src/lux.clj create mode 100644 luxc/src/lux/analyser.clj create mode 100644 luxc/src/lux/analyser/base.clj create mode 100644 luxc/src/lux/analyser/case.clj create mode 100644 luxc/src/lux/analyser/env.clj create mode 100644 luxc/src/lux/analyser/host.clj create mode 100644 luxc/src/lux/analyser/lambda.clj create mode 100644 luxc/src/lux/analyser/lux.clj create mode 100644 luxc/src/lux/analyser/meta.clj create mode 100644 luxc/src/lux/analyser/module.clj create mode 100644 luxc/src/lux/analyser/parser.clj create mode 100644 luxc/src/lux/analyser/record.clj create mode 100644 luxc/src/lux/base.clj create mode 100644 luxc/src/lux/compiler.clj create mode 100644 luxc/src/lux/compiler/base.clj create mode 100644 luxc/src/lux/compiler/cache.clj create mode 100644 luxc/src/lux/compiler/cache/ann.clj create mode 100644 luxc/src/lux/compiler/cache/type.clj create mode 100644 luxc/src/lux/compiler/case.clj create mode 100644 luxc/src/lux/compiler/host.clj create mode 100644 luxc/src/lux/compiler/io.clj create mode 100644 luxc/src/lux/compiler/lambda.clj create mode 100644 luxc/src/lux/compiler/lux.clj create mode 100644 luxc/src/lux/compiler/module.clj create mode 100644 luxc/src/lux/compiler/parallel.clj create mode 100644 luxc/src/lux/host.clj create mode 100644 luxc/src/lux/host/generics.clj create mode 100644 luxc/src/lux/lexer.clj create mode 100644 luxc/src/lux/lib/loader.clj create mode 100644 luxc/src/lux/optimizer.clj create mode 100644 luxc/src/lux/parser.clj create mode 100644 luxc/src/lux/reader.clj create mode 100644 luxc/src/lux/repl.clj create mode 100644 luxc/src/lux/type.clj create mode 100644 luxc/src/lux/type/host.clj create mode 100644 luxc/test/test/lux/lexer.clj create mode 100644 luxc/test/test/lux/parser.clj create mode 100644 luxc/test/test/lux/reader.clj create mode 100644 luxc/test/test/lux/type.clj delete mode 100644 project.clj delete mode 100644 src/lux.clj delete mode 100644 src/lux/analyser.clj delete mode 100644 src/lux/analyser/base.clj delete mode 100644 src/lux/analyser/case.clj delete mode 100644 src/lux/analyser/env.clj delete mode 100644 src/lux/analyser/host.clj delete mode 100644 src/lux/analyser/lambda.clj delete mode 100644 src/lux/analyser/lux.clj delete mode 100644 src/lux/analyser/meta.clj delete mode 100644 src/lux/analyser/module.clj delete mode 100644 src/lux/analyser/parser.clj delete mode 100644 src/lux/analyser/record.clj delete mode 100644 src/lux/base.clj delete mode 100644 src/lux/compiler.clj delete mode 100644 src/lux/compiler/base.clj delete mode 100644 src/lux/compiler/cache.clj delete mode 100644 src/lux/compiler/cache/ann.clj delete mode 100644 src/lux/compiler/cache/type.clj delete mode 100644 src/lux/compiler/case.clj delete mode 100644 src/lux/compiler/host.clj delete mode 100644 src/lux/compiler/io.clj delete mode 100644 src/lux/compiler/lambda.clj delete mode 100644 src/lux/compiler/lux.clj delete mode 100644 src/lux/compiler/module.clj delete mode 100644 src/lux/compiler/parallel.clj delete mode 100644 src/lux/host.clj delete mode 100644 src/lux/host/generics.clj delete mode 100644 src/lux/lexer.clj delete mode 100644 src/lux/lib/loader.clj delete mode 100644 src/lux/optimizer.clj delete mode 100644 src/lux/parser.clj delete mode 100644 src/lux/reader.clj delete mode 100644 src/lux/repl.clj delete mode 100644 src/lux/type.clj delete mode 100644 src/lux/type/host.clj create mode 100644 stdlib/README.md create mode 100644 stdlib/license.txt create mode 100644 stdlib/project.clj create mode 100644 stdlib/source/lux.lux create mode 100644 stdlib/source/lux/cli.lux create mode 100644 stdlib/source/lux/codata/cont.lux create mode 100644 stdlib/source/lux/codata/env.lux create mode 100644 stdlib/source/lux/codata/function.lux create mode 100644 stdlib/source/lux/codata/io.lux create mode 100644 stdlib/source/lux/codata/state.lux create mode 100644 stdlib/source/lux/codata/struct/stream.lux create mode 100644 stdlib/source/lux/compiler.lux create mode 100644 stdlib/source/lux/concurrency/actor.lux create mode 100644 stdlib/source/lux/concurrency/atom.lux create mode 100644 stdlib/source/lux/concurrency/frp.lux create mode 100644 stdlib/source/lux/concurrency/promise.lux create mode 100644 stdlib/source/lux/concurrency/stm.lux create mode 100644 stdlib/source/lux/control/applicative.lux create mode 100644 stdlib/source/lux/control/bounded.lux create mode 100644 stdlib/source/lux/control/codec.lux create mode 100644 stdlib/source/lux/control/comonad.lux create mode 100644 stdlib/source/lux/control/effect.lux create mode 100644 stdlib/source/lux/control/enum.lux create mode 100644 stdlib/source/lux/control/eq.lux create mode 100644 stdlib/source/lux/control/fold.lux create mode 100644 stdlib/source/lux/control/functor.lux create mode 100644 stdlib/source/lux/control/hash.lux create mode 100644 stdlib/source/lux/control/monad.lux create mode 100644 stdlib/source/lux/control/monoid.lux create mode 100644 stdlib/source/lux/control/number.lux create mode 100644 stdlib/source/lux/control/ord.lux create mode 100644 stdlib/source/lux/data/bit.lux create mode 100644 stdlib/source/lux/data/bool.lux create mode 100644 stdlib/source/lux/data/char.lux create mode 100644 stdlib/source/lux/data/error.lux create mode 100644 stdlib/source/lux/data/error/exception.lux create mode 100644 stdlib/source/lux/data/format/json.lux create mode 100644 stdlib/source/lux/data/ident.lux create mode 100644 stdlib/source/lux/data/identity.lux create mode 100644 stdlib/source/lux/data/log.lux create mode 100644 stdlib/source/lux/data/maybe.lux create mode 100644 stdlib/source/lux/data/number.lux create mode 100644 stdlib/source/lux/data/product.lux create mode 100644 stdlib/source/lux/data/struct/array.lux create mode 100644 stdlib/source/lux/data/struct/dict.lux create mode 100644 stdlib/source/lux/data/struct/list.lux create mode 100644 stdlib/source/lux/data/struct/queue.lux create mode 100644 stdlib/source/lux/data/struct/set.lux create mode 100644 stdlib/source/lux/data/struct/stack.lux create mode 100644 stdlib/source/lux/data/struct/tree.lux create mode 100644 stdlib/source/lux/data/struct/vector.lux create mode 100644 stdlib/source/lux/data/struct/zipper.lux create mode 100644 stdlib/source/lux/data/sum.lux create mode 100644 stdlib/source/lux/data/text.lux create mode 100644 stdlib/source/lux/data/text/format.lux create mode 100644 stdlib/source/lux/host.lux create mode 100644 stdlib/source/lux/lexer.lux create mode 100644 stdlib/source/lux/macro.lux create mode 100644 stdlib/source/lux/macro/ast.lux create mode 100644 stdlib/source/lux/macro/poly.lux create mode 100644 stdlib/source/lux/macro/poly/eq.lux create mode 100644 stdlib/source/lux/macro/poly/functor.lux create mode 100644 stdlib/source/lux/macro/poly/text-encoder.lux create mode 100644 stdlib/source/lux/macro/syntax.lux create mode 100644 stdlib/source/lux/macro/syntax/common.lux create mode 100644 stdlib/source/lux/macro/template.lux create mode 100644 stdlib/source/lux/math.lux create mode 100644 stdlib/source/lux/math/complex.lux create mode 100644 stdlib/source/lux/math/random.lux create mode 100644 stdlib/source/lux/math/ratio.lux create mode 100644 stdlib/source/lux/pipe.lux create mode 100644 stdlib/source/lux/regex.lux create mode 100644 stdlib/source/lux/test.lux create mode 100644 stdlib/source/lux/type.lux create mode 100644 stdlib/source/lux/type/auto.lux create mode 100644 stdlib/source/lux/type/check.lux create mode 100644 stdlib/test/test/lux.lux create mode 100644 stdlib/test/test/lux/cli.lux create mode 100644 stdlib/test/test/lux/codata/env.lux create mode 100644 stdlib/test/test/lux/codata/io.lux create mode 100644 stdlib/test/test/lux/codata/state.lux create mode 100644 stdlib/test/test/lux/codata/struct/stream.lux create mode 100644 stdlib/test/test/lux/concurrency/actor.lux create mode 100644 stdlib/test/test/lux/concurrency/frp.lux create mode 100644 stdlib/test/test/lux/concurrency/promise.lux create mode 100644 stdlib/test/test/lux/concurrency/stm.lux create mode 100644 stdlib/test/test/lux/data/bit.lux create mode 100644 stdlib/test/test/lux/data/bool.lux create mode 100644 stdlib/test/test/lux/data/char.lux create mode 100644 stdlib/test/test/lux/data/error.lux create mode 100644 stdlib/test/test/lux/data/format/json.lux create mode 100644 stdlib/test/test/lux/data/ident.lux create mode 100644 stdlib/test/test/lux/data/identity.lux create mode 100644 stdlib/test/test/lux/data/log.lux create mode 100644 stdlib/test/test/lux/data/maybe.lux create mode 100644 stdlib/test/test/lux/data/number.lux create mode 100644 stdlib/test/test/lux/data/product.lux create mode 100644 stdlib/test/test/lux/data/struct/array.lux create mode 100644 stdlib/test/test/lux/data/struct/dict.lux create mode 100644 stdlib/test/test/lux/data/struct/list.lux create mode 100644 stdlib/test/test/lux/data/struct/queue.lux create mode 100644 stdlib/test/test/lux/data/struct/set.lux create mode 100644 stdlib/test/test/lux/data/struct/stack.lux create mode 100644 stdlib/test/test/lux/data/struct/tree.lux create mode 100644 stdlib/test/test/lux/data/struct/vector.lux create mode 100644 stdlib/test/test/lux/data/struct/zipper.lux create mode 100644 stdlib/test/test/lux/data/sum.lux create mode 100644 stdlib/test/test/lux/data/text.lux create mode 100644 stdlib/test/test/lux/data/text/format.lux create mode 100644 stdlib/test/test/lux/host.lux create mode 100644 stdlib/test/test/lux/lexer.lux create mode 100644 stdlib/test/test/lux/macro/ast.lux create mode 100644 stdlib/test/test/lux/macro/syntax.lux create mode 100644 stdlib/test/test/lux/math.lux create mode 100644 stdlib/test/test/lux/pipe.lux create mode 100644 stdlib/test/test/lux/regex.lux create mode 100644 stdlib/test/test/lux/type.lux create mode 100644 stdlib/test/tests.lux delete mode 100644 test/test/lux/lexer.clj delete mode 100644 test/test/lux/parser.clj delete mode 100644 test/test/lux/reader.clj delete mode 100644 test/test/lux/type.clj diff --git a/.gitignore b/.gitignore index 9c8887842..9c23db8ed 100644 --- a/.gitignore +++ b/.gitignore @@ -1,14 +1,11 @@ -/target -/classes -/checkouts +/luxc/target +/luxc/classes +/luxc/checkouts pom.xml pom.xml.asc *.jar *.class /.lein-* /.nrepl-port -LICENSE -README.md -doc/intro.md -/jbe +/luxc/jbe diff --git a/code_of_conduct.md b/code_of_conduct.md deleted file mode 100644 index 01b8644f1..000000000 --- a/code_of_conduct.md +++ /dev/null @@ -1,22 +0,0 @@ -# Contributor Code of Conduct - -As contributors and maintainers of this project, and in the interest of fostering an open and welcoming community, we pledge to respect all people who contribute through reporting issues, posting feature requests, updating documentation, submitting pull requests or patches, and other activities. - -We are committed to making participation in this project a harassment-free experience for everyone, regardless of level of experience, gender, gender identity and expression, sexual orientation, disability, personal appearance, body size, race, ethnicity, age, religion, or nationality. - -Examples of unacceptable behavior by participants include: - -* The use of sexualized language or imagery -* Personal attacks -* Trolling or insulting/derogatory comments -* Public or private harassment -* Publishing other's private information, such as physical or electronic addresses, without explicit permission -* Other unethical or unprofessional conduct. - -Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct. By adopting this Code of Conduct, project maintainers commit themselves to fairly and consistently applying these principles to every aspect of managing this project. Project maintainers who do not follow or enforce the Code of Conduct may be permanently removed from the project team. - -This code of conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. - -Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by opening an issue or contacting one or more of the project maintainers. - -This Code of Conduct is adapted from the [Contributor Covenant](http://contributor-covenant.org), version 1.2.0, available at [http://contributor-covenant.org/version/1/2/0/](http://contributor-covenant.org/version/1/2/0/) diff --git a/license.txt b/license.txt deleted file mode 100644 index 52d135112..000000000 --- a/license.txt +++ /dev/null @@ -1,374 +0,0 @@ -Mozilla Public License Version 2.0 -================================== - -1. Definitions --------------- - -1.1. "Contributor" - means each individual or legal entity that creates, contributes to - the creation of, or owns Covered Software. - -1.2. "Contributor Version" - means the combination of the Contributions of others (if any) used - by a Contributor and that particular Contributor's Contribution. - -1.3. "Contribution" - means Covered Software of a particular Contributor. - -1.4. "Covered Software" - means Source Code Form to which the initial Contributor has attached - the notice in Exhibit A, the Executable Form of such Source Code - Form, and Modifications of such Source Code Form, in each case - including portions thereof. - -1.5. "Incompatible With Secondary Licenses" - means - - (a) that the initial Contributor has attached the notice described - in Exhibit B to the Covered Software; or - - (b) that the Covered Software was made available under the terms of - version 1.1 or earlier of the License, but not also under the - terms of a Secondary License. - -1.6. "Executable Form" - means any form of the work other than Source Code Form. - -1.7. "Larger Work" - means a work that combines Covered Software with other material, in - a separate file or files, that is not Covered Software. - -1.8. "License" - means this document. - -1.9. "Licensable" - means having the right to grant, to the maximum extent possible, - whether at the time of the initial grant or subsequently, any and - all of the rights conveyed by this License. - -1.10. "Modifications" - means any of the following: - - (a) any file in Source Code Form that results from an addition to, - deletion from, or modification of the contents of Covered - Software; or - - (b) any new file in Source Code Form that contains any Covered - Software. - -1.11. "Patent Claims" of a Contributor - means any patent claim(s), including without limitation, method, - process, and apparatus claims, in any patent Licensable by such - Contributor that would be infringed, but for the grant of the - License, by the making, using, selling, offering for sale, having - made, import, or transfer of either its Contributions or its - Contributor Version. - -1.12. "Secondary License" - means either the GNU General Public License, Version 2.0, the GNU - Lesser General Public License, Version 2.1, the GNU Affero General - Public License, Version 3.0, or any later versions of those - licenses. - -1.13. "Source Code Form" - means the form of the work preferred for making modifications. - -1.14. "You" (or "Your") - means an individual or a legal entity exercising rights under this - License. For legal entities, "You" includes any entity that - controls, is controlled by, or is under common control with You. For - purposes of this definition, "control" means (a) the power, direct - or indirect, to cause the direction or management of such entity, - whether by contract or otherwise, or (b) ownership of more than - fifty percent (50%) of the outstanding shares or beneficial - ownership of such entity. - -2. License Grants and Conditions --------------------------------- - -2.1. Grants - -Each Contributor hereby grants You a world-wide, royalty-free, -non-exclusive license: - -(a) under intellectual property rights (other than patent or trademark) - Licensable by such Contributor to use, reproduce, make available, - modify, display, perform, distribute, and otherwise exploit its - Contributions, either on an unmodified basis, with Modifications, or - as part of a Larger Work; and - -(b) under Patent Claims of such Contributor to make, use, sell, offer - for sale, have made, import, and otherwise transfer either its - Contributions or its Contributor Version. - -2.2. Effective Date - -The licenses granted in Section 2.1 with respect to any Contribution -become effective for each Contribution on the date the Contributor first -distributes such Contribution. - -2.3. Limitations on Grant Scope - -The licenses granted in this Section 2 are the only rights granted under -this License. No additional rights or licenses will be implied from the -distribution or licensing of Covered Software under this License. -Notwithstanding Section 2.1(b) above, no patent license is granted by a -Contributor: - -(a) for any code that a Contributor has removed from Covered Software; - or - -(b) for infringements caused by: (i) Your and any other third party's - modifications of Covered Software, or (ii) the combination of its - Contributions with other software (except as part of its Contributor - Version); or - -(c) under Patent Claims infringed by Covered Software in the absence of - its Contributions. - -This License does not grant any rights in the trademarks, service marks, -or logos of any Contributor (except as may be necessary to comply with -the notice requirements in Section 3.4). - -2.4. Subsequent Licenses - -No Contributor makes additional grants as a result of Your choice to -distribute the Covered Software under a subsequent version of this -License (see Section 10.2) or under the terms of a Secondary License (if -permitted under the terms of Section 3.3). - -2.5. Representation - -Each Contributor represents that the Contributor believes its -Contributions are its original creation(s) or it has sufficient rights -to grant the rights to its Contributions conveyed by this License. - -2.6. Fair Use - -This License is not intended to limit any rights You have under -applicable copyright doctrines of fair use, fair dealing, or other -equivalents. - -2.7. Conditions - -Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted -in Section 2.1. - -3. Responsibilities -------------------- - -3.1. Distribution of Source Form - -All distribution of Covered Software in Source Code Form, including any -Modifications that You create or to which You contribute, must be under -the terms of this License. You must inform recipients that the Source -Code Form of the Covered Software is governed by the terms of this -License, and how they can obtain a copy of this License. You may not -attempt to alter or restrict the recipients' rights in the Source Code -Form. - -3.2. Distribution of Executable Form - -If You distribute Covered Software in Executable Form then: - -(a) such Covered Software must also be made available in Source Code - Form, as described in Section 3.1, and You must inform recipients of - the Executable Form how they can obtain a copy of such Source Code - Form by reasonable means in a timely manner, at a charge no more - than the cost of distribution to the recipient; and - -(b) You may distribute such Executable Form under the terms of this - License, or sublicense it under different terms, provided that the - license for the Executable Form does not attempt to limit or alter - the recipients' rights in the Source Code Form under this License. - -3.3. Distribution of a Larger Work - -You may create and distribute a Larger Work under terms of Your choice, -provided that You also comply with the requirements of this License for -the Covered Software. If the Larger Work is a combination of Covered -Software with a work governed by one or more Secondary Licenses, and the -Covered Software is not Incompatible With Secondary Licenses, this -License permits You to additionally distribute such Covered Software -under the terms of such Secondary License(s), so that the recipient of -the Larger Work may, at their option, further distribute the Covered -Software under the terms of either this License or such Secondary -License(s). - -3.4. Notices - -You may not remove or alter the substance of any license notices -(including copyright notices, patent notices, disclaimers of warranty, -or limitations of liability) contained within the Source Code Form of -the Covered Software, except that You may alter any license notices to -the extent required to remedy known factual inaccuracies. - -3.5. Application of Additional Terms - -You may choose to offer, and to charge a fee for, warranty, support, -indemnity or liability obligations to one or more recipients of Covered -Software. However, You may do so only on Your own behalf, and not on -behalf of any Contributor. You must make it absolutely clear that any -such warranty, support, indemnity, or liability obligation is offered by -You alone, and You hereby agree to indemnify every Contributor for any -liability incurred by such Contributor as a result of warranty, support, -indemnity or liability terms You offer. You may include additional -disclaimers of warranty and limitations of liability specific to any -jurisdiction. - -4. Inability to Comply Due to Statute or Regulation ---------------------------------------------------- - -If it is impossible for You to comply with any of the terms of this -License with respect to some or all of the Covered Software due to -statute, judicial order, or regulation then You must: (a) comply with -the terms of this License to the maximum extent possible; and (b) -describe the limitations and the code they affect. Such description must -be placed in a text file included with all distributions of the Covered -Software under this License. Except to the extent prohibited by statute -or regulation, such description must be sufficiently detailed for a -recipient of ordinary skill to be able to understand it. - -5. Termination --------------- - -5.1. The rights granted under this License will terminate automatically -if You fail to comply with any of its terms. However, if You become -compliant, then the rights granted under this License from a particular -Contributor are reinstated (a) provisionally, unless and until such -Contributor explicitly and finally terminates Your grants, and (b) on an -ongoing basis, if such Contributor fails to notify You of the -non-compliance by some reasonable means prior to 60 days after You have -come back into compliance. Moreover, Your grants from a particular -Contributor are reinstated on an ongoing basis if such Contributor -notifies You of the non-compliance by some reasonable means, this is the -first time You have received notice of non-compliance with this License -from such Contributor, and You become compliant prior to 30 days after -Your receipt of the notice. - -5.2. If You initiate litigation against any entity by asserting a patent -infringement claim (excluding declaratory judgment actions, -counter-claims, and cross-claims) alleging that a Contributor Version -directly or indirectly infringes any patent, then the rights granted to -You by any and all Contributors for the Covered Software under Section -2.1 of this License shall terminate. - -5.3. In the event of termination under Sections 5.1 or 5.2 above, all -end user license agreements (excluding distributors and resellers) which -have been validly granted by You or Your distributors under this License -prior to termination shall survive termination. - -************************************************************************ -* * -* 6. Disclaimer of Warranty * -* ------------------------- * -* * -* Covered Software is provided under this License on an "as is" * -* basis, without warranty of any kind, either expressed, implied, or * -* statutory, including, without limitation, warranties that the * -* Covered Software is free of defects, merchantable, fit for a * -* particular purpose or non-infringing. The entire risk as to the * -* quality and performance of the Covered Software is with You. * -* Should any Covered Software prove defective in any respect, You * -* (not any Contributor) assume the cost of any necessary servicing, * -* repair, or correction. This disclaimer of warranty constitutes an * -* essential part of this License. No use of any Covered Software is * -* authorized under this License except under this disclaimer. * -* * -************************************************************************ - -************************************************************************ -* * -* 7. Limitation of Liability * -* -------------------------- * -* * -* Under no circumstances and under no legal theory, whether tort * -* (including negligence), contract, or otherwise, shall any * -* Contributor, or anyone who distributes Covered Software as * -* permitted above, be liable to You for any direct, indirect, * -* special, incidental, or consequential damages of any character * -* including, without limitation, damages for lost profits, loss of * -* goodwill, work stoppage, computer failure or malfunction, or any * -* and all other commercial damages or losses, even if such party * -* shall have been informed of the possibility of such damages. This * -* limitation of liability shall not apply to liability for death or * -* personal injury resulting from such party's negligence to the * -* extent applicable law prohibits such limitation. Some * -* jurisdictions do not allow the exclusion or limitation of * -* incidental or consequential damages, so this exclusion and * -* limitation may not apply to You. * -* * -************************************************************************ - -8. Litigation -------------- - -Any litigation relating to this License may be brought only in the -courts of a jurisdiction where the defendant maintains its principal -place of business and such litigation shall be governed by laws of that -jurisdiction, without reference to its conflict-of-law provisions. -Nothing in this Section shall prevent a party's ability to bring -cross-claims or counter-claims. - -9. Miscellaneous ----------------- - -This License represents the complete agreement concerning the subject -matter hereof. If any provision of this License is held to be -unenforceable, such provision shall be reformed only to the extent -necessary to make it enforceable. Any law or regulation which provides -that the language of a contract shall be construed against the drafter -shall not be used to construe this License against a Contributor. - -10. Versions of the License ---------------------------- - -10.1. New Versions - -Mozilla Foundation is the license steward. Except as provided in Section -10.3, no one other than the license steward has the right to modify or -publish new versions of this License. Each version will be given a -distinguishing version number. - -10.2. Effect of New Versions - -You may distribute the Covered Software under the terms of the version -of the License under which You originally received the Covered Software, -or under the terms of any subsequent version published by the license -steward. - -10.3. Modified Versions - -If you create software not governed by this License, and you want to -create a new license for such software, you may create and use a -modified version of this License if you rename the license and remove -any references to the name of the license steward (except to note that -such modified license differs from this License). - -10.4. Distributing Source Code Form that is Incompatible With Secondary -Licenses - -If You choose to distribute Source Code Form that is Incompatible With -Secondary Licenses under the terms of this version of the License, the -notice described in Exhibit B of this License must be attached. - -Exhibit A - Source Code Form License Notice -------------------------------------------- - - This Source Code Form is subject to the terms of the Mozilla Public - License, v. 2.0. If a copy of the MPL was not distributed with this - file, You can obtain one at http://mozilla.org/MPL/2.0/. - -If it is not possible or desirable to put the notice in a particular -file, then You may include the notice in a location (such as a LICENSE -file in a relevant directory) where a recipient would be likely to look -for such a notice. - -You may add additional accurate notices of copyright ownership. - -Exhibit B - "Incompatible With Secondary Licenses" Notice ---------------------------------------------------------- - - This Source Code Form is "Incompatible With Secondary Licenses", as - defined by the Mozilla Public License, v. 2.0. - diff --git a/lux-lein/LICENSE b/lux-lein/LICENSE new file mode 100644 index 000000000..786edf6b2 --- /dev/null +++ b/lux-lein/LICENSE @@ -0,0 +1,214 @@ +THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC +LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM +CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. + +1. DEFINITIONS + +"Contribution" means: + +a) in the case of the initial Contributor, the initial code and +documentation distributed under this Agreement, and + +b) in the case of each subsequent Contributor: + +i) changes to the Program, and + +ii) additions to the Program; + +where such changes and/or additions to the Program originate from and are +distributed by that particular Contributor. A Contribution 'originates' from +a Contributor if it was added to the Program by such Contributor itself or +anyone acting on such Contributor's behalf. Contributions do not include +additions to the Program which: (i) are separate modules of software +distributed in conjunction with the Program under their own license +agreement, and (ii) are not derivative works of the Program. + +"Contributor" means any person or entity that distributes the Program. + +"Licensed Patents" mean patent claims licensable by a Contributor which are +necessarily infringed by the use or sale of its Contribution alone or when +combined with the Program. + +"Program" means the Contributions distributed in accordance with this +Agreement. + +"Recipient" means anyone who receives the Program under this Agreement, +including all Contributors. + +2. GRANT OF RIGHTS + +a) Subject to the terms of this Agreement, each Contributor hereby grants +Recipient a non-exclusive, worldwide, royalty-free copyright license to +reproduce, prepare derivative works of, publicly display, publicly perform, +distribute and sublicense the Contribution of such Contributor, if any, and +such derivative works, in source code and object code form. + +b) Subject to the terms of this Agreement, each Contributor hereby grants +Recipient a non-exclusive, worldwide, royalty-free patent license under +Licensed Patents to make, use, sell, offer to sell, import and otherwise +transfer the Contribution of such Contributor, if any, in source code and +object code form. This patent license shall apply to the combination of the +Contribution and the Program if, at the time the Contribution is added by the +Contributor, such addition of the Contribution causes such combination to be +covered by the Licensed Patents. The patent license shall not apply to any +other combinations which include the Contribution. No hardware per se is +licensed hereunder. + +c) Recipient understands that although each Contributor grants the licenses +to its Contributions set forth herein, no assurances are provided by any +Contributor that the Program does not infringe the patent or other +intellectual property rights of any other entity. Each Contributor disclaims +any liability to Recipient for claims brought by any other entity based on +infringement of intellectual property rights or otherwise. As a condition to +exercising the rights and licenses granted hereunder, each Recipient hereby +assumes sole responsibility to secure any other intellectual property rights +needed, if any. For example, if a third party patent license is required to +allow Recipient to distribute the Program, it is Recipient's responsibility +to acquire that license before distributing the Program. + +d) Each Contributor represents that to its knowledge it has sufficient +copyright rights in its Contribution, if any, to grant the copyright license +set forth in this Agreement. + +3. REQUIREMENTS + +A Contributor may choose to distribute the Program in object code form under +its own license agreement, provided that: + +a) it complies with the terms and conditions of this Agreement; and + +b) its license agreement: + +i) effectively disclaims on behalf of all Contributors all warranties and +conditions, express and implied, including warranties or conditions of title +and non-infringement, and implied warranties or conditions of merchantability +and fitness for a particular purpose; + +ii) effectively excludes on behalf of all Contributors all liability for +damages, including direct, indirect, special, incidental and consequential +damages, such as lost profits; + +iii) states that any provisions which differ from this Agreement are offered +by that Contributor alone and not by any other party; and + +iv) states that source code for the Program is available from such +Contributor, and informs licensees how to obtain it in a reasonable manner on +or through a medium customarily used for software exchange. + +When the Program is made available in source code form: + +a) it must be made available under this Agreement; and + +b) a copy of this Agreement must be included with each copy of the Program. + +Contributors may not remove or alter any copyright notices contained within +the Program. + +Each Contributor must identify itself as the originator of its Contribution, +if any, in a manner that reasonably allows subsequent Recipients to identify +the originator of the Contribution. + +4. COMMERCIAL DISTRIBUTION + +Commercial distributors of software may accept certain responsibilities with +respect to end users, business partners and the like. While this license is +intended to facilitate the commercial use of the Program, the Contributor who +includes the Program in a commercial product offering should do so in a +manner which does not create potential liability for other Contributors. +Therefore, if a Contributor includes the Program in a commercial product +offering, such Contributor ("Commercial Contributor") hereby agrees to defend +and indemnify every other Contributor ("Indemnified Contributor") against any +losses, damages and costs (collectively "Losses") arising from claims, +lawsuits and other legal actions brought by a third party against the +Indemnified Contributor to the extent caused by the acts or omissions of such +Commercial Contributor in connection with its distribution of the Program in +a commercial product offering. The obligations in this section do not apply +to any claims or Losses relating to any actual or alleged intellectual +property infringement. In order to qualify, an Indemnified Contributor must: +a) promptly notify the Commercial Contributor in writing of such claim, and +b) allow the Commercial Contributor tocontrol, and cooperate with the +Commercial Contributor in, the defense and any related settlement +negotiations. The Indemnified Contributor may participate in any such claim +at its own expense. + +For example, a Contributor might include the Program in a commercial product +offering, Product X. That Contributor is then a Commercial Contributor. If +that Commercial Contributor then makes performance claims, or offers +warranties related to Product X, those performance claims and warranties are +such Commercial Contributor's responsibility alone. Under this section, the +Commercial Contributor would have to defend claims against the other +Contributors related to those performance claims and warranties, and if a +court requires any other Contributor to pay any damages as a result, the +Commercial Contributor must pay those damages. + +5. NO WARRANTY + +EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON +AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER +EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR +CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A +PARTICULAR PURPOSE. Each Recipient is solely responsible for determining the +appropriateness of using and distributing the Program and assumes all risks +associated with its exercise of rights under this Agreement , including but +not limited to the risks and costs of program errors, compliance with +applicable laws, damage to or loss of data, programs or equipment, and +unavailability or interruption of operations. + +6. DISCLAIMER OF LIABILITY + +EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY +CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION +LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE +EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY +OF SUCH DAMAGES. + +7. GENERAL + +If any provision of this Agreement is invalid or unenforceable under +applicable law, it shall not affect the validity or enforceability of the +remainder of the terms of this Agreement, and without further action by the +parties hereto, such provision shall be reformed to the minimum extent +necessary to make such provision valid and enforceable. + +If Recipient institutes patent litigation against any entity (including a +cross-claim or counterclaim in a lawsuit) alleging that the Program itself +(excluding combinations of the Program with other software or hardware) +infringes such Recipient's patent(s), then such Recipient's rights granted +under Section 2(b) shall terminate as of the date such litigation is filed. + +All Recipient's rights under this Agreement shall terminate if it fails to +comply with any of the material terms or conditions of this Agreement and +does not cure such failure in a reasonable period of time after becoming +aware of such noncompliance. If all Recipient's rights under this Agreement +terminate, Recipient agrees to cease use and distribution of the Program as +soon as reasonably practicable. However, Recipient's obligations under this +Agreement and any licenses granted by Recipient relating to the Program shall +continue and survive. + +Everyone is permitted to copy and distribute copies of this Agreement, but in +order to avoid inconsistency the Agreement is copyrighted and may only be +modified in the following manner. The Agreement Steward reserves the right to +publish new versions (including revisions) of this Agreement from time to +time. No one other than the Agreement Steward has the right to modify this +Agreement. The Eclipse Foundation is the initial Agreement Steward. The +Eclipse Foundation may assign the responsibility to serve as the Agreement +Steward to a suitable separate entity. Each new version of the Agreement will +be given a distinguishing version number. The Program (including +Contributions) may always be distributed subject to the version of the +Agreement under which it was received. In addition, after a new version of +the Agreement is published, Contributor may elect to distribute the Program +(including its Contributions) under the new version. Except as expressly +stated in Sections 2(a) and 2(b) above, Recipient receives no rights or +licenses to the intellectual property of any Contributor under this +Agreement, whether expressly, by implication, estoppel or otherwise. All +rights in the Program not expressly granted under this Agreement are +reserved. + +This Agreement is governed by the laws of the State of Washington and the +intellectual property laws of the United States of America. No party to this +Agreement will bring a legal action under this Agreement more than one year +after the cause of action arose. Each party waives its rights to a jury trial +in any resulting litigation. diff --git a/lux-lein/README.md b/lux-lein/README.md new file mode 100644 index 000000000..6d024a58f --- /dev/null +++ b/lux-lein/README.md @@ -0,0 +1,27 @@ +# How to use it + +You'll need a project.clj that imports the lein-luxc plugin. + +Here's an example: + +``` +(defproject com.github.luxlang/lux-stdlib "0.4.0" + :description "Standard library for the Lux programming language." + :url "https://github.com/LuxLang/stdlib" + :license {:name "Mozilla Public License (Version 2.0)" + :url "https://www.mozilla.org/en-US/MPL/2.0/"} + :plugins [[com.github.luxlang/lein-luxc "0.3.0"]] + :source-paths ["source"] + ) + +``` + +Now, all you need to do is run the plugin like this: + + lein luxc compile + +And, if you want to run unit-tests, you can do: + + lein luxc test + +Those unit tests must be in the `test` directory on your project root. diff --git a/lux-lein/license.txt b/lux-lein/license.txt new file mode 100644 index 000000000..52d135112 --- /dev/null +++ b/lux-lein/license.txt @@ -0,0 +1,374 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. + diff --git a/lux-lein/project.clj b/lux-lein/project.clj new file mode 100644 index 000000000..69cc7ff17 --- /dev/null +++ b/lux-lein/project.clj @@ -0,0 +1,21 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(defproject com.github.luxlang/lein-luxc "0.5.0-SNAPSHOT" + :description "The Leiningen plugin for the Lux programming language." + :url "https://github.com/LuxLang/lein-luxc" + :license {:name "Mozilla Public License" + :url "https://www.mozilla.org/en-US/MPL/2.0/"} + :dependencies [[org.clojure/clojure "1.6.0"] + [com.github.luxlang/luxc-jvm "0.5.0-SNAPSHOT"] + [com.github.luxlang/lux-stdlib "0.5.0-SNAPSHOT"]] + :deploy-repositories [["releases" {:url "https://oss.sonatype.org/service/local/staging/deploy/maven2/" + :creds :gpg}] + ["snapshots" {:url "https://oss.sonatype.org/content/repositories/snapshots/" + :creds :gpg}]] + :pom-addition [:developers [:developer + [:name "Eduardo Julian"] + [:url "https://github.com/eduardoejp"]]] + :eval-in :leiningen) diff --git a/lux-lein/src/leiningen/luxc.clj b/lux-lein/src/leiningen/luxc.clj new file mode 100644 index 000000000..b04e4997a --- /dev/null +++ b/lux-lein/src/leiningen/luxc.clj @@ -0,0 +1,27 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns leiningen.luxc + (:require [leiningen.pom :as pom] + [leiningen.core.classpath :as classpath] + (leiningen.luxc [compiler :as &compiler] + [test :as &test] + [repl :as &repl]))) + +;; [Exports] +(defn luxc [project & args] + (case (first args) + "compile" + (&compiler/compile project) + + "test" + (&test/test project) + + "repl" + (&repl/repl project) + + ;; default... + (println "Commands available: compile, test, repl")) + ) diff --git a/lux-lein/src/leiningen/luxc/compiler.clj b/lux-lein/src/leiningen/luxc/compiler.clj new file mode 100644 index 000000000..18eef63a0 --- /dev/null +++ b/lux-lein/src/leiningen/luxc/compiler.clj @@ -0,0 +1,19 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns leiningen.luxc.compiler + (:refer-clojure :exclude [compile]) + (:require [leiningen.core.classpath :as classpath] + (leiningen.luxc [utils :as &utils] + [packager :as &packager]))) + +(defn compile [project] + (if-let [program-module (get-in project [:lux :program])] + (do (&utils/run-process (&utils/compile-path project program-module (get project :source-paths (list))) + nil + "[COMPILATION BEGIN]" + "[COMPILATION END]") + (&packager/package project program-module (get project :resource-paths (list)))) + (println "Please provide a program main module in [:lux :program]"))) diff --git a/lux-lein/src/leiningen/luxc/packager.clj b/lux-lein/src/leiningen/luxc/packager.clj new file mode 100644 index 000000000..e7b1d71d8 --- /dev/null +++ b/lux-lein/src/leiningen/luxc/packager.clj @@ -0,0 +1,212 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns leiningen.luxc.packager + (:require [clojure.string :as string] + [leiningen.core.classpath :as classpath] + [leiningen.uberjar] + [leiningen.luxc.utils :as &utils]) + (:import (java.io InputStream + File + FileInputStream + FileOutputStream + BufferedInputStream + ByteArrayInputStream + ByteArrayOutputStream) + (java.util.jar Manifest + Attributes$Name + JarEntry + JarInputStream + JarOutputStream + ))) + +;; [Utils] +(def ^:private kilobyte 1024) +(def ^:private buffer-size (* 10 kilobyte)) + +(defn ^:private manifest + "(-> Project Text Bool Manifest)" + [project module includes-android?] + (doto (new Manifest) + (-> .getMainAttributes + (doto (-> (.put Attributes$Name/MAIN_CLASS (str module "._")) + (->> (when (not includes-android?)))) + (.put Attributes$Name/MANIFEST_VERSION "1.0") + (.put (new Attributes$Name "LUX_JAR") "true") + (-> (.put (new Attributes$Name name) real-v) + (->> (doseq [[name v] (get project :manifest) + :let [real-v (if (string? v) v (v project))]]))))))) + +(defn ^:private write-class! + "(-> Text File JarOutputStream Null)" + [^String path ^File file ^JarOutputStream out] + (with-open [in (new BufferedInputStream (new FileInputStream file))] + (let [buffer (byte-array buffer-size)] + (doto out + (.putNextEntry (new JarEntry (str path "/" (.getName file)))) + (-> (.write buffer 0 bytes-read) + (->> (when (not= -1 bytes-read)) + (loop [bytes-read (.read in buffer)]))) + (.flush) + (.closeEntry) + )) + )) + +(defn ^:private write-module! + "(-> File JarOutputStream Null)" + [^File file ^JarOutputStream out output-dir] + (let [output-dir-size (inc (.length output-dir)) + module-name (.substring (.getPath file) output-dir-size) + inner-files (.listFiles file) + inner-modules (filter #(.isDirectory ^File %) inner-files) + inner-classes (filter #(not (.isDirectory ^File %)) inner-files)] + (doseq [$class inner-classes] + (write-class! module-name $class out)) + (doseq [$module inner-modules] + (write-module! $module out output-dir)))) + +(defn ^:private write-resources! + "(-> JarOutputStream (List Text) Null)" + [^JarOutputStream out resources-dirs] + (doseq [resources-dir resources-dirs + :let [resources-dir (new File resources-dir)] + :when (.exists resources-dir) + ^File res (.listFiles resources-dir) + :let [buffer (byte-array buffer-size)]] + (with-open [in (->> res (new FileInputStream) (new BufferedInputStream))] + (doto out + (.putNextEntry (new JarEntry (.getName res))) + (-> (.write buffer 0 bytes-read) + (->> (when (not= -1 bytes-read)) + (loop [bytes-read (.read in buffer)]))) + (.flush) + (.closeEntry)) + ))) + +(let [init-capacity (* 100 1024) + buffer-size 1024] + (defn ^:private ^"[B" read-stream [^InputStream is] + (let [buffer (byte-array buffer-size)] + (with-open [os (new ByteArrayOutputStream init-capacity)] + (loop [bytes-read (.read is buffer 0 buffer-size)] + (when (not= -1 bytes-read) + (do (.write os buffer 0 bytes-read) + (recur (.read is buffer 0 buffer-size))))) + (.toByteArray os))))) + +(defn ^:private add-jar! [^File jar-file project !all-jar-files] + (with-open [is (->> jar-file (new FileInputStream) (new JarInputStream))] + (loop [^JarEntry entry (.getNextJarEntry is)] + (when entry + (let [entry-name (.getName entry)] + (if (and (not (.isDirectory entry)) + (not (.startsWith entry-name "META-INF/maven/")) + (not (some (fn [exclusion] + (re-find exclusion entry-name)) + (get project :uberjar-exclusions)))) + (let [entry-data (read-stream is) + entry-data (or (some (fn [[pattern [read fuse write]]] + (let [matches? (if (string? pattern) + (= pattern entry-name) + (re-find pattern entry-name))] + (when matches? + (let [os (new ByteArrayOutputStream 1024) + [_data _entry] (get @!all-jar-files entry-name [(byte-array 0) nil]) + _ (write os (fuse (read (new ByteArrayInputStream _data)) + (read (new ByteArrayInputStream entry-data))))] + (.toByteArray os))))) + (eval (get project :uberjar-merge-with))) + entry-data)] + (swap! !all-jar-files assoc entry-name [entry-data entry]) + (recur (.getNextJarEntry is))) + (recur (.getNextJarEntry is)))) + )))) + +(def default-manifest-file "./AndroidManifest.xml") + +;; [Resources] +(defn package + "(-> Text (List Text) Null)" + [project module resources-dirs] + (let [output-dir (get-in project [:lux :target] &utils/output-dir) + output-package (str (get-in project [:lux :target] &utils/output-dir) "/" + (get project :jar-name &utils/output-package)) + !all-jar-files (atom {}) + includes-android? (boolean (some #(-> % first (= 'com.google.android/android)) + (get project :dependencies))) + project* (-> project + (update-in [:dependencies] (fn [_deps] + ;; Skip the last two, + ;; because they are: + ;; tools.nrepl-0.2.12.jar and + ;; clojure-complete-0.2.4.jar + ;; and they belong to Leiningen. + (take (- (count _deps) 2) _deps)))) + deps (->> project* + (classpath/resolve-managed-dependencies :dependencies :managed-dependencies) + (map #(.getAbsolutePath ^File %)))] + (do (.delete (new File output-package)) + (with-open [out (new JarOutputStream + (->> output-package (new File) (new FileOutputStream)) + (manifest project module includes-android?))] + (do (doseq [$group (.listFiles (new File output-dir))] + (write-module! $group out output-dir)) + (when (not (get-in project [:lux :android])) + (write-resources! out resources-dirs)) + (doseq [^String file-path deps] + (add-jar! (new File file-path) project !all-jar-files)) + (doseq [[_ [entry-data entry]] @!all-jar-files] + (doto out + (.putNextEntry (doto entry (.setCompressedSize -1))) + (.write entry-data 0 (alength entry-data)) + (.flush) + (.closeEntry))) + nil)) + (when (get-in project [:lux :android]) + (let [output-dex "classes.dex" + _ (do (.delete (new File output-dex)) + (&utils/run-process (str "dx --dex --output=" output-dex " " output-package) + (new File (get-in project [:lux :target] &utils/output-dir)) + "[DX BEGIN]" + "[DX END]")) + manifest-path (get-in project [:lux :android :manifest] default-manifest-file) + sdk-path (get-in project [:lux :android :sdk]) + android-path (str sdk-path "/platforms/android-" (get-in project [:lux :android :version]) "/android.jar") + _ (assert (.exists (new File android-path)) + (str "Can't find Android JAR: " android-path)) + output-apk-unaligned (string/replace output-package #"\.jar$" ".apk.unaligned") + output-apk (string/replace output-package #"\.jar$" ".apk") + current-working-dir (.getCanonicalPath (new File ".")) + _ (do (&utils/run-process (str "aapt package -f -M " manifest-path " -I " android-path " -F " output-apk-unaligned + (apply str " " (interleave (repeat (count resources-dirs) + "-A ") + (filter #(.exists (new File %)) + resources-dirs))) + (apply str " " (interleave (repeat (count resources-dirs) + "-S ") + (->> (get-in project [:lux :android :resources] ["android-resources"]) + (map (partial str current-working-dir "/")) + (filter #(.exists (new File %))))))) + nil + "[AAPT PACKAGE BEGIN]" + "[AAPT PACKAGE END]") + (&utils/run-process (str "aapt add -f " output-apk-unaligned " " output-dex) + (new File (get-in project [:lux :target] &utils/output-dir)) + "[AAPT ADD BEGIN]" + "[AAPT ADD END]") + (when-let [path (get-in project [:lux :android :keystore :path])] + (when-let [alias (get-in project [:lux :android :keystore :alias])] + (when-let [password (get-in project [:lux :android :keystore :password])] + (&utils/run-process (str "jarsigner -storepass " password " -keystore " path " " output-apk-unaligned " " alias) + nil + "[JARSIGNER BEGIN]" + "[JARSIGNER END]")))) + (&utils/run-process (str "zipalign 4 " output-apk-unaligned " " output-apk) + nil + "[ZIPALIGN BEGIN]" + "[ZIPALIGN END]") + ) + ] + nil))))) diff --git a/lux-lein/src/leiningen/luxc/repl.clj b/lux-lein/src/leiningen/luxc/repl.clj new file mode 100644 index 000000000..2bfb281e6 --- /dev/null +++ b/lux-lein/src/leiningen/luxc/repl.clj @@ -0,0 +1,35 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns leiningen.luxc.repl + (:require [leiningen.core.classpath :as classpath] + [leiningen.luxc.utils :as &utils]) + (:import (java.io InputStreamReader + BufferedReader + PrintStream))) + +(defn repl [project] + (println (&utils/repl-path project (:source-paths project))) + ;; (let [process (.exec (Runtime/getRuntime) (&utils/repl-path project (:source-paths project)))] + ;; (with-open [std-in (->> System/in (new InputStreamReader) (new BufferedReader)) + ;; process-in (->> process .getOutputStream (new PrintStream)) + ;; process-out (->> process .getInputStream (new InputStreamReader) (new BufferedReader)) + ;; process-err (->> process .getErrorStream (new InputStreamReader) (new BufferedReader))] + ;; (loop [] + ;; (do (loop [] + ;; (when (.ready process-out) + ;; (println (.readLine process-out)) + ;; (recur))) + ;; (loop [had-error? false] + ;; (if (.ready process-out) + ;; (do (println (.readLine process-err)) + ;; (recur true)) + ;; (when had-error? + ;; (System/exit 1)))) + ;; (when-let [input (.readLine std-in)] + ;; (do (.println process-in input) + ;; (recur))))) + ;; )) + ) diff --git a/lux-lein/src/leiningen/luxc/test.clj b/lux-lein/src/leiningen/luxc/test.clj new file mode 100644 index 000000000..a1b5a830c --- /dev/null +++ b/lux-lein/src/leiningen/luxc/test.clj @@ -0,0 +1,27 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns leiningen.luxc.test + (:refer-clojure :exclude [test]) + (:require [leiningen.core.classpath :as classpath] + (leiningen.luxc [utils :as &utils] + [packager :as &packager]))) + +(defn test [project] + (if-let [tests-module (get-in project [:lux :tests])] + (do (&utils/run-process (&utils/compile-path project tests-module (concat (:test-paths project) (:source-paths project))) + nil + "[COMPILATION BEGIN]" + "[COMPILATION END]") + (let [java-cmd (get project :java-cmd "java") + jvm-opts (->> (get project :jvm-opts) (interpose " ") (reduce str "")) + output-package (str (get-in project [:lux :target] &utils/output-dir) "/" + (get project :jar-name &utils/output-package))] + (do (&packager/package project tests-module (get project :resource-paths (list))) + (&utils/run-process (str java-cmd " " jvm-opts " -jar " output-package) + nil + "[TEST BEGIN]" + "[TEST END]")))) + (println "Please provide a test module in [:lux :tests]"))) diff --git a/lux-lein/src/leiningen/luxc/utils.clj b/lux-lein/src/leiningen/luxc/utils.clj new file mode 100644 index 000000000..bae02d365 --- /dev/null +++ b/lux-lein/src/leiningen/luxc/utils.clj @@ -0,0 +1,97 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns leiningen.luxc.utils + (:refer-clojure :exclude [compile]) + (:require [leiningen.core.classpath :as classpath]) + (:import (java.io File + InputStreamReader + BufferedReader))) + +(def ^:const ^String output-dir "target/jvm") +(def ^:const ^String output-package "program.jar") + +(def ^:private unit-separator (str (char 31))) + +(def ^:private vm-options "-server -Xms2048m -Xmx2048m -XX:+OptimizeStringConcat") + +(defn compile-path [project module source-paths] + (let [output-dir (get-in project [:lux :target] output-dir) + jar-paths (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader) + (.getURLs) + (map #(.getFile ^java.net.URL %)) + (filter #(.endsWith ^String % ".jar"))) + compiler-path (some (fn [^:private path] + (if (.contains path "com/github/luxlang/luxc-jvm") + path + nil)) + jar-paths) + stdlib-path (some (fn [^:private path] + (if (.contains path "com/github/luxlang/lux-stdlib") + path + nil)) + jar-paths) + deps-paths (filter (fn [^:private path] + (or (.contains path "org/ow2/asm/asm-all") + (.contains path "org/clojure/core.match") + (.contains path "org/clojure/clojure"))) + jar-paths) + sdk-path (get-in project [:lux :android :sdk]) + android-path (str sdk-path "/platforms/android-" (get-in project [:lux :android :version]) "/android.jar") + deps-paths (if (.exists (new File android-path)) + (cons android-path deps-paths) + deps-paths)] + (let [class-path (->> (classpath/get-classpath project) + (filter #(.endsWith % ".jar")) + (concat deps-paths) + (list* stdlib-path) + (interpose java.io.File/pathSeparator) + (reduce str "")) + java-cmd (get project :java-cmd "java") + jvm-opts (->> (get project :jvm-opts) (interpose " ") (reduce str ""))] + (str java-cmd " " jvm-opts " " vm-options " -cp " (str compiler-path ":" class-path) + " lux release " module + " " (->> (get project :resource-paths (list)) (interpose unit-separator) (apply str)) + " " (->> source-paths (interpose unit-separator) (apply str)) + " " output-dir)))) + +(defn repl-path [project source-paths] + (let [jar-paths (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader) + (.getURLs) + (map #(.getFile ^java.net.URL %)) + (filter #(.endsWith ^String % ".jar"))) + compiler-path (some (fn [^:private path] + (if (.contains path "com/github/luxlang/luxc-jvm") + path + nil)) + jar-paths) + deps-paths (filter (fn [^:private path] + (or (.contains path "org/ow2/asm/asm-all") + (.contains path "org/clojure/core.match") + (.contains path "org/clojure/clojure"))) + jar-paths)] + (let [class-path (->> (classpath/get-classpath project) (filter #(.endsWith % ".jar")) (concat deps-paths) (interpose ":") (reduce str "")) + java-cmd (get project :java-cmd "java") + jvm-opts (->> (get project :jvm-opts) (interpose " ") (reduce str ""))] + (str java-cmd " " jvm-opts " " vm-options " -cp " (str compiler-path ":" class-path) + " lux repl " (->> source-paths (interpose unit-separator) (apply str)))))) + +(defn run-process [command working-directory pre post] + (let [process (.exec (Runtime/getRuntime) command nil working-directory)] + (with-open [std-out (->> process .getInputStream (new InputStreamReader) (new BufferedReader)) + std-err (->> process .getErrorStream (new InputStreamReader) (new BufferedReader))] + (println pre) + (loop [line (.readLine std-out)] + (when line + (println line) + (recur (.readLine std-out)))) + (loop [had-error? false + line (.readLine std-err)] + (if line + (do (println line) + (recur true (.readLine std-err))) + (when had-error? + (System/exit 1)))) + (println post)))) diff --git a/lux-mode/README.md b/lux-mode/README.md new file mode 100644 index 000000000..c4807434d --- /dev/null +++ b/lux-mode/README.md @@ -0,0 +1,16 @@ +## Lux Mode + +An Emacs mode for *the Lux programming language*. + +You can create a directory inside your .emacs.d directory named "el_files" + +Then, you can add this to your *init.el* file: + + (add-to-list 'load-path "~/.emacs.d/el_files/") + (require 'lux-mode) + +If you use Paredit or Rainbow-parens, you can hook them up to Lux mode: + + (add-hook 'lux-mode-hook #'paredit-mode) + (add-hook 'lux-mode-hook #'rainbow-delimiters-mode) + diff --git a/lux-mode/lux-mode.el b/lux-mode/lux-mode.el new file mode 100644 index 000000000..8290430af --- /dev/null +++ b/lux-mode/lux-mode.el @@ -0,0 +1,398 @@ +;;; lux-mode.el --- Major mode for Lux code -*- lexical-binding: t; -*- + +;; Copyright © 2015 Eduardo Julian +;; +;; Authors: Eduardo Julian +;; URL: http://github.com/lux/lux-mode +;; Keywords: languages lisp lux +;; Version: 0.1.0 +;; Package-Requires: ((emacs "24.1")) + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Based on the code for clojure-mode (http://github.com/clojure-emacs/clojure-mode) +;; By Jeffrey Chu et al + +;; Provides font-lock, indentation, and navigation for the Lux programming language. + +;; Using lux-mode with paredit or smartparens is highly recommended. + +;; Here are some example configurations: + +;; ;; require or autoload paredit-mode +;; (add-hook 'lux-mode-hook #'paredit-mode) + +;; ;; require or autoload smartparens +;; (add-hook 'lux-mode-hook #'smartparens-strict-mode) + +;;; License: + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Compatibility +(eval-and-compile + ;; `setq-local' for Emacs 24.2 and below + (unless (fboundp 'setq-local) + (defmacro setq-local (var val) + "Set variable VAR to value VAL in current buffer." + `(set (make-local-variable ',var) ,val)))) + +(eval-when-compile + (defvar calculate-lisp-indent-last-sexp) + (defvar font-lock-beg) + (defvar font-lock-end) + (defvar paredit-space-for-delimiter-predicates) + (defvar paredit-version) + (defvar paredit-mode)) + +(require 'cl) +(require 'imenu) + +(defgroup lux nil + "Major mode for editing Lux code." + :prefix "lux-" + :group 'languages + :link '(url-link :tag "Github" "https://github.com/lux/lux-mode") + :link '(emacs-commentary-link :tag "Commentary" "lux-mode")) + +(defconst lux-mode-version "0.1.0" + "The current version of `lux-mode'.") + +(defcustom lux-defun-style-default-indent nil + "When non-nil, use default indenting for functions and macros. +Otherwise check `define-lux-indent' and `put-lux-indent'." + :type 'boolean + :group 'lux + :safe 'booleanp) + +(defvar lux-mode-map + (make-sparse-keymap) + "Keymap for Lux mode. Inherits from `lisp-mode-shared-map'.") + +(defvar lux-mode-syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?\( "()2n" table) + (modify-syntax-entry ?\) ")(3n" table) + (modify-syntax-entry ?\{ "(}" table) + (modify-syntax-entry ?\} "){" table) + (modify-syntax-entry ?\[ "(]" table) + (modify-syntax-entry ?\] ")[" table) + (modify-syntax-entry ?\" "\"\"" table) + (modify-syntax-entry ?\\ "\\" table) + (modify-syntax-entry ?# "w 124b" table) + (modify-syntax-entry ?\n "> b" table) + (modify-syntax-entry '(?a . ?z) "w" table) + (modify-syntax-entry '(?A . ?Z) "w" table) + (modify-syntax-entry '(?0 . ?9) "w" table) + (modify-syntax-entry ?~ "w" table) + (modify-syntax-entry ?' "w" table) + (modify-syntax-entry ?` "w" table) + (modify-syntax-entry ?! "w" table) + (modify-syntax-entry ?@ "w" table) + (modify-syntax-entry ?$ "w" table) + (modify-syntax-entry ?% "w" table) + (modify-syntax-entry ?^ "w" table) + (modify-syntax-entry ?& "w" table) + (modify-syntax-entry ?* "w" table) + (modify-syntax-entry ?- "w" table) + (modify-syntax-entry ?_ "w" table) + (modify-syntax-entry ?+ "w" table) + (modify-syntax-entry ?= "w" table) + (modify-syntax-entry ?| "w" table) + (modify-syntax-entry ?: "w" table) + (modify-syntax-entry ?. "w" table) + (modify-syntax-entry ?, "w" table) + (modify-syntax-entry ?/ "w" table) + (modify-syntax-entry ?? "w" table) + (modify-syntax-entry ?< "w" table) + (modify-syntax-entry ?> "w" table) + (modify-syntax-entry ?\; "w" table) + ;; (modify-syntax-entry ?\\ "w" table) + (modify-syntax-entry ?\s "-" table) + (modify-syntax-entry ?\t "-" table) + (modify-syntax-entry ?\r "-" table) + table)) + +(defun lux-mode-display-version () + "Display the current `lux-mode-version' in the minibuffer." + (interactive) + (message "lux-mode (version %s)" lux-mode-version)) + +(defun lux-space-for-delimiter-p (endp delim) + "Prevent paredit from inserting useless spaces. +See `paredit-space-for-delimiter-predicates' for the meaning of +ENDP and DELIM." + (if (derived-mode-p 'lux-mode) + (save-excursion + (backward-char) + (if (and (or (char-equal delim ?\() + (char-equal delim ?\") + (char-equal delim ?{)) + (not endp)) + (if (char-equal (char-after) ?#) + (and (not (bobp)) + (or (char-equal ?w (char-syntax (char-before))) + (char-equal ?_ (char-syntax (char-before))))) + t) + t)) + t)) + +(defun lux-paredit-setup () + "Make \"paredit-mode\" play nice with `lux-mode'." + (when (>= paredit-version 21) + (define-key lux-mode-map "{" #'paredit-open-curly) + (define-key lux-mode-map "}" #'paredit-close-curly) + (add-to-list 'paredit-space-for-delimiter-predicates + #'lux-space-for-delimiter-p))) + +(defun lux-mode-variables () + "Set up initial buffer-local variables for Lux mode." + (setq-local imenu-create-index-function + (lambda () + (imenu--generic-function '((nil lux-match-next-def 0))))) + (setq-local comment-start "## ") + (setq-local comment-end "") + (setq-local indent-tabs-mode nil) + (setq-local multibyte-syntax-as-symbol t) + (setq-local electric-pair-skip-whitespace 'chomp) + (setq-local electric-pair-open-newline-between-pairs nil) + (setq-local indent-line-function #'lisp-indent-line) + (setq-local lisp-indent-function #'lux-indent-function) + (setq-local parse-sexp-ignore-comments t) + (setq-local open-paren-in-column-0-is-defun-start nil)) + +;;;###autoload +(define-derived-mode lux-mode prog-mode "Lux" + "Major mode for editing Lux code. + +\\{lux-mode-map}" + (lux-mode-variables) + (lux-font-lock-setup) + (add-hook 'paredit-mode-hook #'lux-paredit-setup) + (define-key lux-mode-map [remap comment-dwim] 'lux-comment-dwim)) + +(defun lux-match-next-def () + "Scans the buffer backwards for the next \"top-level\" definition. +Called by `imenu--generic-function'." + (when (re-search-backward "^(def\\sw*" nil t) + (save-excursion + (let (found? + (start (point))) + (down-list) + (forward-sexp) + (while (not found?) + (forward-sexp) + (or (if (char-equal ?[ (char-after (point))) + (backward-sexp)) + (if (char-equal ?) (char-after (point))) + (backward-sexp))) + (destructuring-bind (def-beg . def-end) (bounds-of-thing-at-point 'sexp) + (if (char-equal ?^ (char-after def-beg)) + (progn (forward-sexp) (backward-sexp)) + (setq found? t) + (set-match-data (list def-beg def-end))))) + (goto-char start))))) + +(defconst lux-font-lock-keywords + (eval-when-compile + `(; Special forms + (,(concat + "(" + (regexp-opt + '(";module:" "def:" "type:" "sig:" "struct:" "macro:" "syntax:" "program:" "poly:" "derived:" "actor:" "test:" "template:" "class:" "interface:" "model:" + "exception:" + "lambda" "case" ":" ":!" ":!!" "undefined" "ident-for" + "and" "or" + "exec" "let" "let%" "if" "cond" "do" "be" "open" "loop" "recur" "comment" "list" "list&" "io" "vector" "tree" + "get@" "set@" "update@" "|>" "|>." "<|" "_$" "$_" "~" "~@" "~'" "::" ":::" "default" + "|" "&" "->" "All" "Ex" "Rec" "host" "$" "type" + "^" "^or" "^slots" "^stream&" "^=>" "^~" "^@" "^template" "^open" "^|>" + "bin" "oct" "hex" + "@pre" "@post" + "sig" "struct" "derive" + "infix" + "format" + "`" "`'" "'" "do-template" "with-gensyms" + "object" "jvm-import" "do-to" "with-open" "synchronized" "class-for" + "doc" + "||E" "||F" "||H" "effect:" "handler:" "with-handler" "doE" "lift" + "regex" + ) t) + "\\>") + 1 font-lock-builtin-face) + ; Bool literals + (,(concat + "\\<" + (regexp-opt + '("true" "false") t) + "\\>") + 0 font-lock-constant-face) + ; Char literals - #"1", #"a", #"\n", #"\u0000" + ("#\".+\"" 0 font-lock-constant-face) + ; Nat literals + ("\\<\\+\\(0\\|[1-9][0-9,_]*\\)\\>" 0 font-lock-constant-face) + ; Int|Real literals + ("\\<-?\\(0\\|[1-9][0-9,_]*\\)\\(\\.[0-9,_]+\\)?\\>" 0 font-lock-constant-face) + ; Frac literals + ("\\<\\(\\.[0-9,_]+\\)\\>" 0 font-lock-constant-face) + ; Tags + ("#;[a-zA-Z0-9-\\+_=!@\\$%\\^&\\*<>\.,/\\\\\\|':~\\?]+" 0 font-lock-type-face) + ("#;;[a-zA-Z0-9-\\+_=!@\\$%\\^&\\*<>\.,/\\\\\\|':~\\?]+" 0 font-lock-type-face) + ("#[a-zA-Z0-9-\\+_=!@\\$%\\^&\\*<>\.,/\\\\\\|':~\\?]+\\(;[a-zA-Z0-9-\\+_=!@\\$%\\^&\\*<>\.,/\\\\\\|':~\\?]+\\)?" 0 font-lock-type-face) + )) + "Default expressions to highlight in Lux mode.") + +(defun lux-font-lock-syntactic-face-function (state) + "Find and highlight text with a Lux-friendly syntax table. + +This function is passed to `font-lock-syntactic-face-function', +which is called with a single parameter, STATE (which is, in +turn, returned by `parse-partial-sexp' at the beginning of the +highlighted region)." + (if (nth 3 state) + ;; This might be a string or a |...| symbol. + (let ((startpos (nth 8 state))) + (if (eq (char-after startpos) ?|) + ;; This is not a string, but a |...| symbol. + nil + font-lock-constant-face)) + font-lock-comment-face)) + +(defun lux-font-lock-setup () + "Configures font-lock for editing Lux code." + (setq-local font-lock-multiline t) + (setq font-lock-defaults + '(lux-font-lock-keywords ; keywords + nil nil + (("+-*/.<>=!?$%_&~^:@" . "w")) ; syntax alist + nil + (font-lock-mark-block-function . mark-defun) + (font-lock-syntactic-face-function + . lux-font-lock-syntactic-face-function)))) + +(defun lux-indent-function (indent-point state) + "When indenting a line within a function call, indent properly. + +INDENT-POINT is the position where the user typed TAB, or equivalent. +Point is located at the point to indent under (for default indentation); +STATE is the `parse-partial-sexp' state for that position. + +If the current line is in a call to a Lux function with a +non-nil property `lux-indent-function', that specifies how to do +the indentation. + +The property value can be + +- `defun', meaning indent `defun'-style; +- an integer N, meaning indent the first N arguments specially + like ordinary function arguments and then indent any further + arguments like a body; +- a function to call just as this function was called. + If that function returns nil, that means it doesn't specify + the indentation. + +This function also returns nil meaning don't specify the indentation." + (let ((normal-indent (current-column))) + (goto-char (1+ (elt state 1))) + (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) + (if (and (elt state 2) + (not (looking-at "\\sw\\|\\s_"))) + ;; car of form doesn't seem to be a symbol + (progn + (if (not (> (save-excursion (forward-line 1) (point)) + calculate-lisp-indent-last-sexp)) + (progn (goto-char calculate-lisp-indent-last-sexp) + (beginning-of-line) + (parse-partial-sexp (point) + calculate-lisp-indent-last-sexp 0 t))) + ;; Indent under the list or under the first sexp on the same + ;; line as calculate-lisp-indent-last-sexp. Note that first + ;; thing on that line has to be complete sexp since we are + ;; inside the innermost containing sexp. + (backward-prefix-chars) + (current-column)) + (let* ((function (buffer-substring (point) + (progn (forward-sexp 1) (point)))) + (open-paren (elt state 1)) + (method nil) + (function-tail (first + (last + (split-string (substring-no-properties function) ";"))))) + (setq method (get (intern-soft function-tail) 'lux-indent-function)) + (cond ((member (char-after open-paren) '(?\[ ?\{)) + (goto-char open-paren) + (1+ (current-column))) + ((or (eq method 'defun) + (and (null method) + (> (length function) 3) + (string-match "\\`\\(?:\\S +/\\)?\\(\\w+:\\|with-\\)" + function))) + (lisp-indent-defform state indent-point)) + ((integerp method) + (lisp-indent-specform method state + indent-point normal-indent)) + (method + (funcall method indent-point state)) + ))))) + +(defun put-lux-indent (sym indent) + "Instruct `lux-indent-function' to indent the body of SYM by INDENT." + (put sym 'lux-indent-function indent)) + +(defmacro define-lux-indent (&rest kvs) + "Call `put-lux-indent' on a series, KVS." + `(progn + ,@(mapcar (lambda (x) `(put-lux-indent + (quote ,(first x)) ,(second x))) + kvs))) + +(define-lux-indent + (def 'defun) + (lambda 'defun) + (let 'defun) + (let% 'defun) + (case 'defun) + (do 'defun) + (exec 'defun) + (be 'defun) + (if 1) + (cond 0) + (loop 1) + (do-template 'defun) + (All 'defun) + (Ex 'defun) + (Rec 'defun) + (_lux_def 'defun) + (_lux_case 'defun) + (_lux_lambda 'defun) + (synchronized 'defun) + (object 'defun) + (do-to 'defun) + (jvm-import 'defun) + (with-gensyms 'defun) + (testing 'defun) + (comment 'defun) + (doE 'defun) + (^template 'defun) + (default 'defun) + ) + +;;;###autoload + + +(provide 'lux-mode) diff --git a/luxc/code_of_conduct.md b/luxc/code_of_conduct.md new file mode 100644 index 000000000..01b8644f1 --- /dev/null +++ b/luxc/code_of_conduct.md @@ -0,0 +1,22 @@ +# Contributor Code of Conduct + +As contributors and maintainers of this project, and in the interest of fostering an open and welcoming community, we pledge to respect all people who contribute through reporting issues, posting feature requests, updating documentation, submitting pull requests or patches, and other activities. + +We are committed to making participation in this project a harassment-free experience for everyone, regardless of level of experience, gender, gender identity and expression, sexual orientation, disability, personal appearance, body size, race, ethnicity, age, religion, or nationality. + +Examples of unacceptable behavior by participants include: + +* The use of sexualized language or imagery +* Personal attacks +* Trolling or insulting/derogatory comments +* Public or private harassment +* Publishing other's private information, such as physical or electronic addresses, without explicit permission +* Other unethical or unprofessional conduct. + +Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct. By adopting this Code of Conduct, project maintainers commit themselves to fairly and consistently applying these principles to every aspect of managing this project. Project maintainers who do not follow or enforce the Code of Conduct may be permanently removed from the project team. + +This code of conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. + +Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by opening an issue or contacting one or more of the project maintainers. + +This Code of Conduct is adapted from the [Contributor Covenant](http://contributor-covenant.org), version 1.2.0, available at [http://contributor-covenant.org/version/1/2/0/](http://contributor-covenant.org/version/1/2/0/) diff --git a/luxc/license.txt b/luxc/license.txt new file mode 100644 index 000000000..52d135112 --- /dev/null +++ b/luxc/license.txt @@ -0,0 +1,374 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. + diff --git a/luxc/project.clj b/luxc/project.clj new file mode 100644 index 000000000..4650fbd58 --- /dev/null +++ b/luxc/project.clj @@ -0,0 +1,30 @@ +(defproject com.github.luxlang/luxc-jvm "0.5.0-SNAPSHOT" + :min-lein-version "2.1.0" ;; 2.1.0 introduced jar classifiers + :description "The JVM compiler for the Lux programming language." + :url "https://github.com/LuxLang/lux" + :license {:name "Mozilla Public License (Version 2.0)" + :url "https://www.mozilla.org/en-US/MPL/2.0/"} + :deploy-repositories [["releases" {:url "https://oss.sonatype.org/service/local/staging/deploy/maven2/" + :creds :gpg}] + ["snapshots" {:url "https://oss.sonatype.org/content/repositories/snapshots/" + :creds :gpg}]] + :pom-addition [:developers [:developer + [:name "Eduardo Julian"] + [:url "https://github.com/eduardoejp"]]] + :dependencies [[org.clojure/clojure "1.6.0"] + [org.clojure/core.match "0.2.1"] + [org.ow2.asm/asm-all "5.0.3"]] + :warn-on-reflection true + :main lux + :repositories [["snapshots" "https://oss.sonatype.org/content/repositories/snapshots/"] + ["releases" "https://oss.sonatype.org/service/local/staging/deploy/maven2/"]] + :source-paths ["src"] + + :classifiers {:sources {:resource-paths ["src"]} + :javadoc {:resource-paths ["src"]}} + + :aot [lux] + + :jvm-opts ^:replace ["-server" "-Xms2048m" "-Xmx2048m" + "-XX:+OptimizeStringConcat"] + ) diff --git a/luxc/src/lux.clj b/luxc/src/lux.clj new file mode 100644 index 000000000..4f73f79e0 --- /dev/null +++ b/luxc/src/lux.clj @@ -0,0 +1,52 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux + (:gen-class) + (:require [lux.base :as & :refer [|let |do return fail return* fail* |case]] + [lux.compiler.base :as &compiler-base] + [lux.compiler :as &compiler] + [lux.repl :as &repl] + [clojure.string :as string] + :reload-all) + (:import (java.io File))) + +(def unit-separator (str (char 31))) + +(defn ^:private process-dirs + "(-> Text (List Text))" + [resources-dirs] + (-> resources-dirs + (string/replace unit-separator "\n") + string/split-lines + &/->list)) + +(defn -main [& args] + (|case (&/->list args) + (&/$Cons "release" (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil)))))) + (time (&compiler/compile-program &/$Release program-module (process-dirs resources-dirs) (process-dirs source-dirs) target-dir)) + + (&/$Cons "debug" (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil)))))) + (time (&compiler/compile-program &/$Debug program-module (process-dirs resources-dirs) (process-dirs source-dirs) target-dir)) + + (&/$Cons "repl" (&/$Cons source-dirs (&/$Nil))) + (&repl/repl (process-dirs source-dirs)) + + _ + (println "Can't understand command."))) + +(comment + (-main "release" "tests" + "/home/eduardoejp/workspace/projects/lux-stdlib/resources" + (str "/home/eduardoejp/workspace/projects/lux-stdlib/source" unit-separator + "/home/eduardoejp/workspace/projects/lux-stdlib/test") + "/home/eduardoejp/workspace/projects/lux/target/jvm") + + (-main "release" "tests" + "/home/eduardoejp/workspace/projects/lux-stdlib/resources" + (str "/home/eduardoejp/workspace/projects/lux-stdlib/source" unit-separator + "/home/eduardoejp/workspace/projects/lux-stdlib/test") + "/home/eduardoejp/workspace/projects/lux-stdlib/target/jvm") + ) diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj new file mode 100644 index 000000000..4133927e7 --- /dev/null +++ b/luxc/src/lux/analyser.clj @@ -0,0 +1,211 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return fail return* fail* |case]] + [reader :as &reader] + [parser :as &parser] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &&] + [lux :as &&lux] + [host :as &&host] + [module :as &&module] + [parser :as &&a-parser]))) + +;; [Utils] +(defn analyse-variant+ [analyse exo-type ident values] + (|do [[module tag-name] (&/normalize ident) + _ (&&module/ensure-can-see-tag module tag-name) + idx (&&module/tag-index module tag-name) + group (&&module/tag-group module tag-name) + :let [is-last? (= idx (dec (&/|length group)))]] + (if (= 1 (&/|length group)) + (|do [_cursor &/cursor] + (analyse exo-type (&/T [_cursor (&/$TupleS values)]))) + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if (or ? (&&/type-tag? module tag-name)) + (&&lux/analyse-variant analyse (&/$Right exo-type) idx is-last? values) + (|do [wanted-type (&&module/tag-type module tag-name) + wanted-type* (&type/instantiate-inference wanted-type) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyse (&/$Left wanted-type*) idx is-last? values)) + _ (&type/check exo-type variant-type)] + (return (&/|list (&&/|meta exo-type variant-cursor variant-analysis)))))) + + _ + (&&lux/analyse-variant analyse (&/$Right exo-type) idx is-last? values) + )) + )) + +(defn ^:private just-analyse [analyser syntax] + (&type/with-var + (fn [?var] + (|do [[[?output-type ?output-cursor] ?output-term] (&&/analyse-1 analyser ?var syntax)] + (|case [?var ?output-type] + [(&/$VarT ?e-id) (&/$VarT ?a-id)] + (if (= ?e-id ?a-id) + (|do [=output-type (&type/clean ?var ?output-type)] + (return (&&/|meta =output-type ?output-cursor ?output-term))) + (|do [=output-type (&type/clean ?var ?var)] + (return (&&/|meta =output-type ?output-cursor ?output-term)))) + + [_ _] + (|do [=output-type (&type/clean ?var ?output-type)] + (return (&&/|meta =output-type ?output-cursor ?output-term)))) + )))) + +(defn ^:private analyse-ast [optimize eval! compile-module compilers exo-type ?token] + (|let [analyse (partial analyse-ast optimize eval! compile-module compilers) + [cursor token] ?token + [compile-def compile-program compile-class compile-interface] compilers] + (|case token + ;; Standard special forms + (&/$BoolS ?value) + (|do [_ (&type/check exo-type &type/Bool)] + (return (&/|list (&&/|meta exo-type cursor (&&/$bool ?value))))) + + (&/$NatS ?value) + (|do [_ (&type/check exo-type &type/Nat)] + (return (&/|list (&&/|meta exo-type cursor (&&/$nat ?value))))) + + (&/$IntS ?value) + (|do [_ (&type/check exo-type &type/Int)] + (return (&/|list (&&/|meta exo-type cursor (&&/$int ?value))))) + + (&/$RealS ?value) + (|do [_ (&type/check exo-type &type/Real)] + (return (&/|list (&&/|meta exo-type cursor (&&/$real ?value))))) + + (&/$CharS ?value) + (|do [_ (&type/check exo-type &type/Char)] + (return (&/|list (&&/|meta exo-type cursor (&&/$char ?value))))) + + (&/$TextS ?value) + (|do [_ (&type/check exo-type &type/Text)] + (return (&/|list (&&/|meta exo-type cursor (&&/$text ?value))))) + + (&/$TupleS ?elems) + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-tuple analyse (&/$Right exo-type) ?elems)) + + (&/$RecordS ?elems) + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-record analyse exo-type ?elems)) + + (&/$TagS ?ident) + (&/with-analysis-meta cursor exo-type + (analyse-variant+ analyse exo-type ?ident &/$Nil)) + + (&/$SymbolS ?ident) + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-symbol analyse exo-type ?ident)) + + (&/$FormS (&/$Cons [command-meta command] parameters)) + (|case command + (&/$SymbolS _ command-name) + (case command-name + "_lux_case" + (|let [(&/$Cons ?value ?branches) parameters] + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-case analyse exo-type ?value ?branches))) + + "_lux_lambda" + (|let [(&/$Cons [_ (&/$SymbolS "" ?self)] + (&/$Cons [_ (&/$SymbolS "" ?arg)] + (&/$Cons ?body + (&/$Nil)))) parameters] + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body))) + + "_lux_proc" + (|let [(&/$Cons [_ (&/$TupleS (&/$Cons [_ (&/$TextS ?category)] + (&/$Cons [_ (&/$TextS ?proc)] + (&/$Nil))))] + (&/$Cons [_ (&/$TupleS ?args)] + (&/$Nil))) parameters] + (&/with-analysis-meta cursor exo-type + (&&host/analyse-host analyse exo-type compilers ?category ?proc ?args))) + + "_lux_:" + (|let [(&/$Cons ?type + (&/$Cons ?value + (&/$Nil))) parameters] + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-ann analyse eval! exo-type ?type ?value))) + + "_lux_:!" + (|let [(&/$Cons ?type + (&/$Cons ?value + (&/$Nil))) parameters] + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-coerce analyse eval! exo-type ?type ?value))) + + "_lux_def" + (|let [(&/$Cons [_ (&/$SymbolS "" ?name)] + (&/$Cons ?value + (&/$Cons ?meta + (&/$Nil)) + )) parameters] + (&/with-cursor cursor + (&&lux/analyse-def analyse optimize eval! compile-def ?name ?value ?meta))) + + "_lux_module" + (|let [(&/$Cons ?meta (&/$Nil)) parameters] + (&/with-cursor cursor + (&&lux/analyse-module analyse optimize eval! compile-module ?meta))) + + "_lux_program" + (|let [(&/$Cons [_ (&/$SymbolS "" ?args)] + (&/$Cons ?body + (&/$Nil))) parameters] + (&/with-cursor cursor + (&&lux/analyse-program analyse optimize compile-program ?args ?body))) + + ;; else + (&/with-cursor cursor + (|do [=fn (just-analyse analyse (&/T [command-meta command]))] + (&&lux/analyse-apply analyse cursor exo-type =fn parameters)))) + + (&/$NatS idx) + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-variant analyse (&/$Right exo-type) idx nil parameters)) + + (&/$TagS ?ident) + (&/with-analysis-meta cursor exo-type + (analyse-variant+ analyse exo-type ?ident parameters)) + + _ + (&/with-cursor cursor + (|do [=fn (just-analyse analyse (&/T [command-meta command]))] + (&&lux/analyse-apply analyse cursor exo-type =fn parameters)))) + + _ + (&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T [(&/T ["" -1 -1]) token]))))) + ))) + +;; [Resources] +(defn analyse [optimize eval! compile-module compilers] + (|do [asts &parser/parse] + (&/flat-map% (partial analyse-ast optimize eval! compile-module compilers &/$VoidT) asts))) + +(defn clean-output [?var analysis] + (|do [:let [[[?output-type ?output-cursor] ?output-term] analysis] + =output-type (&type/clean ?var ?output-type)] + (return (&&/|meta =output-type ?output-cursor ?output-term)))) + +(defn repl-analyse [optimize eval! compile-module compilers] + (|do [asts &parser/parse] + (&/flat-map% (fn [ast] + (&type/with-var + (fn [?var] + (|do [=outputs (&/with-closure + (analyse-ast optimize eval! compile-module compilers ?var ast))] + (&/map% (partial clean-output ?var) =outputs))))) + asts))) diff --git a/luxc/src/lux/analyser/base.clj b/luxc/src/lux/analyser/base.clj new file mode 100644 index 000000000..9bdcdeb11 --- /dev/null +++ b/luxc/src/lux/analyser/base.clj @@ -0,0 +1,131 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.base + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [defvariant |let |do return* return fail |case]] + [type :as &type]))) + +;; [Tags] +(defvariant + ("bool" 1) + ("nat" 1) + ("int" 1) + ("frac" 1) + ("real" 1) + ("char" 1) + ("text" 1) + ("variant" 3) + ("tuple" 1) + ("apply" 2) + ("case" 2) + ("lambda" 4) + ("ann" 2) + ("var" 1) + ("captured" 1) + ("proc" 3) + ) + +;; [Exports] +(defn expr-meta [analysis] + (|let [[meta _] analysis] + meta)) + +(defn expr-type* [analysis] + (|let [[[type _] _] analysis] + type)) + +(defn expr-term [analysis] + (|let [[[type _] term] analysis] + term)) + +(defn with-type [new-type analysis] + (|let [[[type cursor] adt] analysis] + (&/T [(&/T [new-type cursor]) adt]))) + +(defn clean-analysis [$var an] + "(-> Type Analysis (Lux Analysis))" + (|do [=an-type (&type/clean $var (expr-type* an))] + (return (with-type =an-type an)))) + +(def jvm-this "_jvm_this") + +(defn cap-1 [action] + (|do [result action] + (|case result + (&/$Cons x (&/$Nil)) + (return x) + + _ + (fail "[Analyser Error] Can't expand to other than 1 element.")))) + +(defn analyse-1 [analyse exo-type elem] + (&/with-expected-type exo-type + (cap-1 (analyse exo-type elem)))) + +(defn analyse-1+ [analyse ?token] + (&type/with-var + (fn [$var] + (|do [=expr (analyse-1 analyse $var ?token)] + (clean-analysis $var =expr))))) + +(defn resolved-ident [ident] + (|do [:let [[?module ?name] ident] + module* (if (.equals "" ?module) + &/get-module-name + (return ?module))] + (return (&/T [module* ?name])))) + +(let [tag-names #{"HostT" "VoidT" "UnitT" "SumT" "ProdT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}] + (defn type-tag? [module name] + (and (= "lux" module) + (contains? tag-names name)))) + +(defn |meta [type cursor analysis] + (&/T [(&/T [type cursor]) analysis])) + +(defn de-meta + "(-> Analysis Analysis)" + [analysis] + (|let [[meta analysis-] analysis] + (|case analysis- + ($variant idx is-last? value) + ($variant idx is-last? (de-meta value)) + + ($tuple elems) + ($tuple (&/|map de-meta elems)) + + ($apply func args) + ($apply (de-meta func) + (&/|map de-meta args)) + + ($case value branches) + ($case (de-meta value) + (&/|map (fn [branch] + (|let [[_pattern _body] branch] + (&/T [_pattern (de-meta _body)]))) + branches)) + + ($lambda _register-offset scope captured body) + ($lambda _register-offset scope + (&/|map (fn [branch] + (|let [[_name _captured] branch] + (&/T [_name (de-meta _captured)]))) + captured) + (de-meta body)) + + ($ann value-expr type-expr) + (de-meta value-expr) + + ($captured scope idx source) + ($captured scope idx (de-meta source)) + + ($proc proc-ident args special-args) + ($proc proc-ident (&/|map de-meta args) special-args) + + _ + analysis- + ))) diff --git a/luxc/src/lux/analyser/case.clj b/luxc/src/lux/analyser/case.clj new file mode 100644 index 000000000..6841577a8 --- /dev/null +++ b/luxc/src/lux/analyser/case.clj @@ -0,0 +1,654 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.case + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [defvariant |do return fail |let |case]] + [parser :as &parser] + [type :as &type]) + (lux.analyser [base :as &&] + [env :as &env] + [module :as &module] + [record :as &&record]))) + +;; [Tags] +(defvariant + ("DefaultTotal" 1) + ("BoolTotal" 2) + ("NatTotal" 2) + ("IntTotal" 2) + ("FracTotal" 2) + ("RealTotal" 2) + ("CharTotal" 2) + ("TextTotal" 2) + ("TupleTotal" 2) + ("VariantTotal" 2)) + +(defvariant + ("NoTestAC" 0) + ("StoreTestAC" 1) + ("BoolTestAC" 1) + ("NatTestAC" 1) + ("IntTestAC" 1) + ("FracTestAC" 1) + ("RealTestAC" 1) + ("CharTestAC" 1) + ("TextTestAC" 1) + ("TupleTestAC" 1) + ("VariantTestAC" 1)) + +;; [Utils] +(def ^:private unit-tuple + (&/T [(&/T ["" -1 -1]) (&/$TupleS &/$Nil)])) + +(defn ^:private resolve-type [type] + (|case type + (&/$VarT ?id) + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (fail "##1##")))] + (resolve-type type*)) + + (&/$UnivQ _) + (|do [$var &type/existential + =type (&type/apply-type type $var)] + (&type/actual-type =type)) + + (&/$ExQ _ _) + (|do [$var &type/existential + =type (&type/apply-type type $var)] + (&type/actual-type =type)) + + _ + (&type/actual-type type))) + +(defn update-up-frame [frame] + (|let [[_env _idx _var] frame] + (&/T [_env (+ 2 _idx) _var]))) + +(defn clean! [level ?tid bound-idx type] + (|case type + (&/$VarT ?id) + (if (= ?tid ?id) + (&/$BoundT (+ (* 2 level) bound-idx)) + type) + + (&/$HostT ?name ?params) + (&/$HostT ?name (&/|map (partial clean! level ?tid bound-idx) + ?params)) + + (&/$LambdaT ?arg ?return) + (&/$LambdaT (clean! level ?tid bound-idx ?arg) + (clean! level ?tid bound-idx ?return)) + + (&/$AppT ?lambda ?param) + (&/$AppT (clean! level ?tid bound-idx ?lambda) + (clean! level ?tid bound-idx ?param)) + + (&/$ProdT ?left ?right) + (&/$ProdT (clean! level ?tid bound-idx ?left) + (clean! level ?tid bound-idx ?right)) + + (&/$SumT ?left ?right) + (&/$SumT (clean! level ?tid bound-idx ?left) + (clean! level ?tid bound-idx ?right)) + + (&/$UnivQ ?env ?body) + (&/$UnivQ (&/|map (partial clean! level ?tid bound-idx) ?env) + (clean! (inc level) ?tid bound-idx ?body)) + + (&/$ExQ ?env ?body) + (&/$ExQ (&/|map (partial clean! level ?tid bound-idx) ?env) + (clean! (inc level) ?tid bound-idx ?body)) + + _ + type + )) + +(defn beta-reduce! [level env type] + (|case type + (&/$HostT ?name ?params) + (&/$HostT ?name (&/|map (partial beta-reduce! level env) ?params)) + + (&/$SumT ?left ?right) + (&/$SumT (beta-reduce! level env ?left) + (beta-reduce! level env ?right)) + + (&/$ProdT ?left ?right) + (&/$ProdT (beta-reduce! level env ?left) + (beta-reduce! level env ?right)) + + (&/$AppT ?type-fn ?type-arg) + (&/$AppT (beta-reduce! level env ?type-fn) + (beta-reduce! level env ?type-arg)) + + (&/$UnivQ ?local-env ?local-def) + (&/$UnivQ ?local-env (beta-reduce! (inc level) env ?local-def)) + + (&/$ExQ ?local-env ?local-def) + (&/$ExQ ?local-env (beta-reduce! (inc level) env ?local-def)) + + (&/$LambdaT ?input ?output) + (&/$LambdaT (beta-reduce! level env ?input) + (beta-reduce! level env ?output)) + + (&/$BoundT ?idx) + (|case (&/|at (- ?idx (* 2 level)) env) + (&/$Some bound) + (beta-reduce! level env bound) + + _ + type) + + _ + type + )) + +(defn apply-type! [type-fn param] + (|case type-fn + (&/$UnivQ local-env local-def) + (return (beta-reduce! 0 (->> local-env + (&/$Cons param) + (&/$Cons type-fn)) + local-def)) + + (&/$ExQ local-env local-def) + (return (beta-reduce! 0 (->> local-env + (&/$Cons param) + (&/$Cons type-fn)) + local-def)) + + (&/$AppT F A) + (|do [type-fn* (apply-type! F A)] + (apply-type! type-fn* param)) + + (&/$NamedT ?name ?type) + (apply-type! ?type param) + + (&/$ExT id) + (return (&/$AppT type-fn param)) + + (&/$VarT id) + (|do [=type-fun (deref id)] + (apply-type! =type-fun param)) + + _ + (fail (str "[Type System] Not a type function:\n" (&type/show-type type-fn) "\n")))) + +(defn adjust-type* [up type] + "(-> (List (, (Maybe (List Type)) Int Type)) Type (Lux Type))" + (|case type + (&/$UnivQ _aenv _abody) + (&type/with-var + (fn [$var] + (|do [=type (apply-type! type $var) + ==type (adjust-type* (&/$Cons (&/T [_aenv 1 $var]) (&/|map update-up-frame up)) =type)] + (&type/clean $var ==type)))) + + (&/$ExQ _aenv _abody) + (|do [$var &type/existential + =type (apply-type! type $var)] + (adjust-type* up =type)) + + (&/$ProdT ?left ?right) + (|do [:let [=type (&/fold (fn [_abody ena] + (|let [[_aenv _aidx (&/$VarT _avar)] ena] + (clean! 0 _avar _aidx _abody))) + type + up)] + :let [distributor (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aidx _avar] ena] + (&/$UnivQ _aenv _abody))) + v + up)) + adjusted-type (&type/Tuple$ (&/|map distributor (&type/flatten-prod =type)))]] + (return adjusted-type)) + + (&/$SumT ?left ?right) + (|do [:let [=type (&/fold (fn [_abody ena] + (|let [[_aenv _aidx (&/$VarT _avar)] ena] + (clean! 0 _avar _aidx _abody))) + type + up)] + :let [distributor (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aidx _avar] ena] + (&/$UnivQ _aenv _abody))) + v + up)) + adjusted-type (&type/Variant$ (&/|map distributor (&type/flatten-sum =type)))]] + (return adjusted-type)) + + (&/$AppT ?tfun ?targ) + (|do [=type (apply-type! ?tfun ?targ)] + (adjust-type* up =type)) + + (&/$VarT ?id) + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (fail (str "##2##: " ?id))))] + (adjust-type* up type*)) + + (&/$NamedT ?name ?type) + (adjust-type* up ?type) + + (&/$UnitT) + (return type) + + _ + (fail (str "[Pattern-matching Error] Can't adjust type: " (&type/show-type type))) + )) + +(defn adjust-type [type] + "(-> Type (Lux Type))" + (adjust-type* &/$Nil type)) + +(defn ^:private analyse-pattern [var?? value-type pattern kont] + (|let [[meta pattern*] pattern] + (|case pattern* + (&/$SymbolS "" name) + (|case var?? + (&/$Some var-analysis) + (|do [=kont (&env/with-alias name var-analysis + kont)] + (return (&/T [$NoTestAC =kont]))) + + _ + (|do [=kont (&env/with-local name value-type + kont) + idx &env/next-local-idx] + (return (&/T [($StoreTestAC idx) =kont])))) + + (&/$SymbolS ident) + (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) + + (&/$BoolS ?value) + (|do [_ (&type/check value-type &type/Bool) + =kont kont] + (return (&/T [($BoolTestAC ?value) =kont]))) + + (&/$NatS ?value) + (|do [_ (&type/check value-type &type/Nat) + =kont kont] + (return (&/T [($NatTestAC ?value) =kont]))) + + (&/$IntS ?value) + (|do [_ (&type/check value-type &type/Int) + =kont kont] + (return (&/T [($IntTestAC ?value) =kont]))) + + (&/$FracS ?value) + (|do [_ (&type/check value-type &type/Frac) + =kont kont] + (return (&/T [($FracTestAC ?value) =kont]))) + + (&/$RealS ?value) + (|do [_ (&type/check value-type &type/Real) + =kont kont] + (return (&/T [($RealTestAC ?value) =kont]))) + + (&/$CharS ?value) + (|do [_ (&type/check value-type &type/Char) + =kont kont] + (return (&/T [($CharTestAC ?value) =kont]))) + + (&/$TextS ?value) + (|do [_ (&type/check value-type &type/Text) + =kont kont] + (return (&/T [($TextTestAC ?value) =kont]))) + + (&/$TupleS ?members) + (|case ?members + (&/$Nil) + (|do [_ (&type/check value-type &/$UnitT) + =kont kont] + (return (&/T [($TupleTestAC (&/|list)) =kont]))) + + (&/$Cons ?member (&/$Nil)) + (analyse-pattern var?? value-type ?member kont) + + _ + (|do [must-infer? (&type/unknown? value-type) + value-type* (if must-infer? + (|do [member-types (&/map% (fn [_] &type/create-var+) (&/|range (&/|length ?members)))] + (return (&type/fold-prod member-types))) + (adjust-type value-type))] + (|case value-type* + (&/$ProdT _) + (|let [num-elems (&/|length ?members) + [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?members) value-type*)] + (if (= num-elems _shorter) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern &/$None v m kont*)] + (return (&/T [(&/$Cons =test =tests) =kont]))))) + (|do [=kont kont] + (return (&/T [&/$Nil =kont]))) + (&/|reverse (&/zip2 _tuple-types ?members)))] + (return (&/T [($TupleTestAC =tests) =kont]))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?members) "]" + " -- " (&/show-ast pattern) + " " (&type/show-type value-type*) " " (&type/show-type value-type))))) + + _ + (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type)))))) + + (&/$RecordS pairs) + (|do [[rec-members rec-type] (&&record/order-record pairs) + must-infer? (&type/unknown? value-type) + rec-type* (if must-infer? + (&type/instantiate-inference rec-type) + (return value-type)) + _ (&type/check value-type rec-type*)] + (analyse-pattern &/$None rec-type* (&/T [meta (&/$TupleS rec-members)]) kont)) + + (&/$TagS ?ident) + (|do [[=module =name] (&&/resolved-ident ?ident) + must-infer? (&type/unknown? value-type) + variant-type (if must-infer? + (|do [variant-type (&module/tag-type =module =name) + variant-type* (&type/instantiate-inference variant-type) + _ (&type/check value-type variant-type*)] + (return variant-type*)) + (return value-type)) + value-type* (adjust-type variant-type) + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + case-type (&type/sum-at idx value-type*) + [=test =kont] (analyse-pattern &/$None case-type unit-tuple kont)] + (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) + + (&/$FormS (&/$Cons [_ (&/$NatS idx)] ?values)) + (|do [value-type* (adjust-type value-type) + case-type (&type/sum-at idx value-type*) + [=test =kont] (case (int (&/|length ?values)) + 0 (analyse-pattern &/$None case-type unit-tuple kont) + 1 (analyse-pattern &/$None case-type (&/|head ?values) kont) + ;; 1+ + (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$TupleS ?values)]) kont))] + (return (&/T [($VariantTestAC (&/T [idx (&/|length (&type/flatten-sum value-type*)) =test])) =kont]))) + + (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) + (|do [[=module =name] (&&/resolved-ident ?ident) + must-infer? (&type/unknown? value-type) + variant-type (if must-infer? + (|do [variant-type (&module/tag-type =module =name) + variant-type* (&type/instantiate-inference variant-type) + _ (&type/check value-type variant-type*)] + (return variant-type*)) + (return value-type)) + value-type* (adjust-type variant-type) + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + case-type (&type/sum-at idx value-type*) + [=test =kont] (case (int (&/|length ?values)) + 0 (analyse-pattern &/$None case-type unit-tuple kont) + 1 (analyse-pattern &/$None case-type (&/|head ?values) kont) + ;; 1+ + (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$TupleS ?values)]) kont))] + (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) + + _ + (fail (str "[Pattern-matching Error] Unrecognized pattern syntax: " (&/show-ast pattern))) + ))) + +(defn ^:private analyse-branch [analyse exo-type var?? value-type pattern body patterns] + (|do [pattern+body (analyse-pattern var?? value-type pattern + (&&/analyse-1 analyse exo-type body))] + (return (&/$Cons pattern+body patterns)))) + +(defn ^:private merge-total [struct test+body] + (|let [[test ?body] test+body] + (|case [struct test] + [($DefaultTotal total?) ($NoTestAC)] + (return ($DefaultTotal true)) + + [($BoolTotal total? ?values) ($NoTestAC)] + (return ($BoolTotal true ?values)) + + [($NatTotal total? ?values) ($NoTestAC)] + (return ($NatTotal true ?values)) + + [($IntTotal total? ?values) ($NoTestAC)] + (return ($IntTotal true ?values)) + + [($FracTotal total? ?values) ($NoTestAC)] + (return ($FracTotal true ?values)) + + [($RealTotal total? ?values) ($NoTestAC)] + (return ($RealTotal true ?values)) + + [($CharTotal total? ?values) ($NoTestAC)] + (return ($CharTotal true ?values)) + + [($TextTotal total? ?values) ($NoTestAC)] + (return ($TextTotal true ?values)) + + [($TupleTotal total? ?values) ($NoTestAC)] + (return ($TupleTotal true ?values)) + + [($VariantTotal total? ?values) ($NoTestAC)] + (return ($VariantTotal true ?values)) + + [($DefaultTotal total?) ($StoreTestAC ?idx)] + (return ($DefaultTotal true)) + + [($BoolTotal total? ?values) ($StoreTestAC ?idx)] + (return ($BoolTotal true ?values)) + + [($NatTotal total? ?values) ($StoreTestAC ?idx)] + (return ($NatTotal true ?values)) + + [($IntTotal total? ?values) ($StoreTestAC ?idx)] + (return ($IntTotal true ?values)) + + [($FracTotal total? ?values) ($StoreTestAC ?idx)] + (return ($FracTotal true ?values)) + + [($RealTotal total? ?values) ($StoreTestAC ?idx)] + (return ($RealTotal true ?values)) + + [($CharTotal total? ?values) ($StoreTestAC ?idx)] + (return ($CharTotal true ?values)) + + [($TextTotal total? ?values) ($StoreTestAC ?idx)] + (return ($TextTotal true ?values)) + + [($TupleTotal total? ?values) ($StoreTestAC ?idx)] + (return ($TupleTotal true ?values)) + + [($VariantTotal total? ?values) ($StoreTestAC ?idx)] + (return ($VariantTotal true ?values)) + + [($DefaultTotal total?) ($BoolTestAC ?value)] + (return ($BoolTotal total? (&/|list ?value))) + + [($BoolTotal total? ?values) ($BoolTestAC ?value)] + (return ($BoolTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($NatTestAC ?value)] + (return ($NatTotal total? (&/|list ?value))) + + [($NatTotal total? ?values) ($NatTestAC ?value)] + (return ($NatTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($IntTestAC ?value)] + (return ($IntTotal total? (&/|list ?value))) + + [($IntTotal total? ?values) ($IntTestAC ?value)] + (return ($IntTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($FracTestAC ?value)] + (return ($FracTotal total? (&/|list ?value))) + + [($FracTotal total? ?values) ($FracTestAC ?value)] + (return ($FracTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($RealTestAC ?value)] + (return ($RealTotal total? (&/|list ?value))) + + [($RealTotal total? ?values) ($RealTestAC ?value)] + (return ($RealTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($CharTestAC ?value)] + (return ($CharTotal total? (&/|list ?value))) + + [($CharTotal total? ?values) ($CharTestAC ?value)] + (return ($CharTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($TextTestAC ?value)] + (return ($TextTotal total? (&/|list ?value))) + + [($TextTotal total? ?values) ($TextTestAC ?value)] + (return ($TextTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($TupleTestAC ?tests)] + (|do [structs (&/map% (fn [t] + (merge-total ($DefaultTotal total?) (&/T [t ?body]))) + ?tests)] + (return ($TupleTotal total? structs))) + + [($TupleTotal total? ?values) ($TupleTestAC ?tests)] + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) + (|do [structs (&/map2% (fn [v t] + (merge-total v (&/T [t ?body]))) + ?values ?tests)] + (return ($TupleTotal total? structs))) + (fail "[Pattern-matching Error] Inconsistent tuple-size.")) + + [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total ($DefaultTotal total?) + (&/T [?test ?body])) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count ($DefaultTotal total?))) + (&/$Some list) + (return list) + + (&/$None) + (fail "[Pattern-matching Error] YOLO"))] + (return ($VariantTotal total? structs))) + + [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) + (&/$Some sub) + sub + + (&/$None) + ($DefaultTotal total?)) + (&/T [?test ?body])) + structs (|case (&/|list-put ?tag sub-struct ?branches) + (&/$Some list) + (return list) + + (&/$None) + (fail "[Pattern-matching Error] YOLO"))] + (return ($VariantTotal total? structs))) + ))) + +(defn check-totality+ [check-totality] + (fn [?token] + (&type/with-var + (fn [$var] + (|do [=output (check-totality $var ?token) + ?type (&type/deref+ $var) + =type (&type/clean $var ?type)] + (return (&/T [=output =type]))))))) + +(defn ^:private check-totality [value-type struct] + (|case struct + ($DefaultTotal ?total) + (return ?total) + + ($BoolTotal ?total ?values) + (|do [_ (&type/check value-type &type/Bool)] + (return (or ?total + (= #{true false} (set (&/->seq ?values)))))) + + ($NatTotal ?total _) + (|do [_ (&type/check value-type &type/Nat)] + (return ?total)) + + ($IntTotal ?total _) + (|do [_ (&type/check value-type &type/Int)] + (return ?total)) + + ($FracTotal ?total _) + (|do [_ (&type/check value-type &type/Frac)] + (return ?total)) + + ($RealTotal ?total _) + (|do [_ (&type/check value-type &type/Real)] + (return ?total)) + + ($CharTotal ?total _) + (|do [_ (&type/check value-type &type/Char)] + (return ?total)) + + ($TextTotal ?total _) + (|do [_ (&type/check value-type &type/Text)] + (return ?total)) + + ($TupleTotal ?total ?structs) + (|case ?structs + (&/$Nil) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$UnitT) + (return true) + + _ + (fail "[Pattern-maching Error] Unit is not total."))) + + _ + (|do [unknown? (&type/unknown? value-type)] + (if unknown? + (|do [=structs (&/map% (check-totality+ check-totality) ?structs) + _ (&type/check value-type (|case (->> (&/|map &/|second =structs) (&/|reverse)) + (&/$Cons last prevs) + (&/fold (fn [right left] (&/$ProdT left right)) + last prevs)))] + (return (or ?total + (&/fold #(and %1 %2) true (&/|map &/|first =structs))))) + (if ?total + (return true) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$ProdT _) + (|let [num-elems (&/|length ?structs) + [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?structs) value-type*)] + (if (= num-elems _shorter) + (|do [totals (&/map2% check-totality _tuple-types ?structs)] + (return (&/fold #(and %1 %2) true totals))) + (fail (str "[Pattern-maching Error] Tuple-mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?structs) "]")))) + + _ + (fail (str "[Pattern-maching Error] Tuple is not total." " - " (&type/show-type value-type*))))))))) + + ($VariantTotal ?total ?structs) + (if ?total + (return true) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$SumT _) + (|do [totals (&/map2% check-totality + (&type/flatten-sum value-type*) + ?structs)] + (return (&/fold #(and %1 %2) true totals))) + + _ + (fail "[Pattern-maching Error] Variant is not total.")))) + )) + +;; [Exports] +(defn analyse-branches [analyse exo-type var?? value-type branches] + (|do [patterns (&/fold% (fn [patterns branch] + (|let [[pattern body] branch] + (analyse-branch analyse exo-type var?? value-type pattern body patterns))) + &/$Nil + branches) + struct (&/fold% merge-total ($DefaultTotal false) patterns) + ? (check-totality value-type struct)] + (if ? + (return patterns) + (fail "[Pattern-maching Error] Pattern-matching is non-total.")))) diff --git a/luxc/src/lux/analyser/env.clj b/luxc/src/lux/analyser/env.clj new file mode 100644 index 000000000..75e066e34 --- /dev/null +++ b/luxc/src/lux/analyser/env.clj @@ -0,0 +1,74 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.env + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return return* fail fail* |case]]) + [lux.analyser.base :as &&])) + +;; [Exports] +(def next-local-idx + (fn [state] + (return* state (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) + +(defn with-local [name type body] + (fn [state] + (let [old-mappings (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$scopes + (fn [stack] + (let [var-analysis (&&/|meta type &/empty-cursor (&&/$var (&/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter)))))] + (&/$Cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [m] (&/|put name var-analysis m)))) + (&/|head stack)) + (&/|tail stack)))) + state))] + (|case =return + (&/$Right ?state ?value) + (return* (&/update$ &/$scopes (fn [stack*] + (&/$Cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) + ?state) + ?value) + + _ + =return)))) + +(defn with-alias [name var-analysis body] + (fn [state] + (let [old-mappings (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$scopes + (fn [stack] + (&/$Cons (&/update$ &/$locals #(->> % + (&/update$ &/$mappings (fn [m] (&/|put name var-analysis m)))) + (&/|head stack)) + (&/|tail stack))) + state))] + (|case =return + (&/$Right ?state ?value) + (return* (&/update$ &/$scopes (fn [stack*] + (&/$Cons (&/update$ &/$locals #(->> % + (&/set$ &/$mappings old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) + ?state) + ?value) + + _ + =return)))) + +(def captured-vars + (fn [state] + (|case (&/get$ &/$scopes state) + (&/$Nil) + (fail* "[Analyser Error] Can't obtain captured vars without environments.") + + (&/$Cons env _) + (return* state (->> env (&/get$ &/$closure) (&/get$ &/$mappings)))) + )) diff --git a/luxc/src/lux/analyser/host.clj b/luxc/src/lux/analyser/host.clj new file mode 100644 index 000000000..209e36d0e --- /dev/null +++ b/luxc/src/lux/analyser/host.clj @@ -0,0 +1,1379 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.host + (:require (clojure [template :refer [do-template]] + [string :as string]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type] + [host :as &host] + [lexer :as &lexer] + [parser :as &parser] + [reader :as &reader]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &&] + [lambda :as &&lambda] + [env :as &&env] + [parser :as &&a-parser]) + [lux.compiler.base :as &c!base]) + (:import (java.lang.reflect Type TypeVariable))) + +;; [Utils] +(defn ^:private ensure-catching [exceptions*] + "(-> (List Text) (Lux Null))" + (|do [class-loader &/loader] + (fn [state] + (|let [exceptions (&/|map #(Class/forName % true class-loader) exceptions*) + catching (->> state + (&/get$ &/$host) + (&/get$ &/$catching) + (&/|map #(Class/forName % true class-loader)))] + (if-let [missing-ex (&/fold (fn [prev ^Class now] + (or prev + (cond (or (.isAssignableFrom java.lang.RuntimeException now) + (.isAssignableFrom java.lang.Error now)) + nil + + (&/fold (fn [found? ^Class ex-catch] + (or found? + (.isAssignableFrom ex-catch now))) + false + catching) + nil + + :else + now))) + nil + exceptions)] + ((&/fail-with-loc (str "[Analyser Error] Unhandled exception: " missing-ex)) + state) + (&/return* state nil))) + ))) + +(defn ^:private with-catches [catches body] + "(All [a] (-> (List Text) (Lux a) (Lux a)))" + (fn [state] + (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) + state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))] + (|case (&/run-state body state*) + (&/$Left msg) + (&/$Left msg) + + (&/$Right state** output) + (&/$Right (&/T [(->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) + output])))) + )) + +(defn ^:private ensure-object [type] + "(-> Type (Lux (, Text (List Type))))" + (|case type + (&/$HostT payload) + (return payload) + + (&/$VarT id) + (return (&/T ["java.lang.Object" (&/|list)])) + + (&/$ExT id) + (return (&/T ["java.lang.Object" (&/|list)])) + + (&/$NamedT _ type*) + (ensure-object type*) + + (&/$UnivQ _ type*) + (ensure-object type*) + + (&/$ExQ _ type*) + (ensure-object type*) + + (&/$AppT F A) + (|do [type* (&type/apply-type F A)] + (ensure-object type*)) + + _ + (&/fail-with-loc (str "[Analyser Error] Expecting object: " (&type/show-type type))))) + +(defn ^:private as-object [type] + "(-> Type Type)" + (|case type + (&/$HostT class params) + (&/$HostT (&host-type/as-obj class) params) + + _ + type)) + +(defn ^:private as-otype [tname] + (case tname + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + tname + )) + +(defn ^:private as-otype+ [type] + "(-> Type Type)" + (|case type + (&/$HostT name params) + (&/$HostT (as-otype name) params) + + _ + type)) + +(defn ^:private clean-gtype-var [idx gtype-var] + (|let [(&/$VarT id) gtype-var] + (|do [? (&type/bound? id)] + (if ? + (|do [real-type (&type/deref id)] + (return (&/T [idx real-type]))) + (return (&/T [(+ 2 idx) (&/$BoundT idx)])))))) + +(defn ^:private clean-gtype-vars [gtype-vars] + (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] + (|do [:let [[idx types] idx+types] + [idx* real-type] (clean-gtype-var idx gtype-var)] + (return (&/T [idx* (&/$Cons real-type types)])))) + (&/T [1 &/$Nil]) + gtype-vars)] + (return clean-types))) + +(defn ^:private make-gtype [class-name type-args] + "(-> Text (List Type) Type)" + (&/fold (fn [base-type type-arg] + (|case type-arg + (&/$BoundT _) + (&/$UnivQ &type/empty-env base-type) + + _ + base-type)) + (&/$HostT class-name type-args) + type-args)) + +;; [Resources] +(defn ^:private analyse-field-access-helper [obj-type gvars gtype] + "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" + (|case obj-type + (&/$HostT class targs) + (if (= (&/|length targs) (&/|length gvars)) + (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) + (&/|table) + gvars + targs)] + (&host-type/instance-param &type/existential gtype-env gtype)) + (&/fail-with-loc (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) + + _ + (&/fail-with-loc (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) + +(defn generic-class->simple-class [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar var-name) + "java.lang.Object" + + (&/$GenericWildcard _) + "java.lang.Object" + + (&/$GenericClass name params) + name + + (&/$GenericArray param) + (|case param + (&/$GenericArray _) + (str "[" (generic-class->simple-class param)) + + (&/$GenericClass "boolean" _) + "[Z" + + (&/$GenericClass "byte" _) + "[B" + + (&/$GenericClass "short" _) + "[S" + + (&/$GenericClass "int" _) + "[I" + + (&/$GenericClass "long" _) + "[J" + + (&/$GenericClass "float" _) + "[F" + + (&/$GenericClass "double" _) + "[D" + + (&/$GenericClass "char" _) + "[C" + + (&/$GenericClass name params) + (str "[L" name ";") + + (&/$GenericTypeVar var-name) + "[Ljava.lang.Object;" + + (&/$GenericWildcard _) + "[Ljava.lang.Object;") + )) + +(defn generic-class->type [env gclass] + "(-> (List (, TypeVar Type)) GenericClass (Lux Type))" + (|case gclass + (&/$GenericTypeVar var-name) + (if-let [ex (&/|get var-name env)] + (return ex) + (&/fail-with-loc (str "[Analysis Error] Unknown type var: " var-name))) + + (&/$GenericClass name params) + (case name + "boolean" (return (&/$HostT "java.lang.Boolean" &/$Nil)) + "byte" (return (&/$HostT "java.lang.Byte" &/$Nil)) + "short" (return (&/$HostT "java.lang.Short" &/$Nil)) + "int" (return (&/$HostT "java.lang.Integer" &/$Nil)) + "long" (return (&/$HostT "java.lang.Long" &/$Nil)) + "float" (return (&/$HostT "java.lang.Float" &/$Nil)) + "double" (return (&/$HostT "java.lang.Double" &/$Nil)) + "char" (return (&/$HostT "java.lang.Character" &/$Nil)) + "void" (return &/$UnitT) + ;; else + (|do [=params (&/map% (partial generic-class->type env) params)] + (return (&/$HostT name =params)))) + + (&/$GenericArray param) + (|do [=param (generic-class->type env param)] + (return (&/$HostT &host-type/array-data-tag (&/|list =param)))) + + (&/$GenericWildcard _) + (return (&/$ExQ &/$Nil (&/$BoundT 1))) + )) + +(defn gen-super-env [class-env supers class-decl] + "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))" + (|let [[class-name class-vars] class-decl] + (|case (&/|some (fn [super] + (|let [[super-name super-params] super] + (if (= class-name super-name) + (&/$Some (&/zip2 (&/|map &/|first class-vars) super-params)) + &/$None))) + supers) + (&/$None) + (&/fail-with-loc (str "[Analyser Error] Unrecognized super-class: " class-name)) + + (&/$Some vars+gtypes) + (&/map% (fn [var+gtype] + (|do [:let [[var gtype] var+gtype] + =gtype (generic-class->type class-env gtype)] + (return (&/T [var =gtype])))) + vars+gtypes) + ))) + +(defn ^:private make-type-env [type-params] + "(-> (List TypeParam) (Lux (List [Text Type])))" + (&/map% (fn [gvar] + (|do [:let [[gvar-name _] gvar] + ex &type/existential] + (return (&/T [gvar-name ex])))) + type-params)) + +(defn ^:private double-register-gclass? [gclass] + (|case gclass + (&/$GenericClass name _) + (|case name + "long" true + "double" true + _ false) + + _ + false)) + +(defn ^:private method-input-folder [full-env] + (fn [body* input*] + (|do [:let [[iname itype*] input*] + itype (generic-class->type full-env itype*)] + (if (double-register-gclass? itype*) + (&&env/with-local iname itype + (&&env/with-local "" &/$VoidT + body*)) + (&&env/with-local iname itype + body*))))) + +(defn ^:private analyse-method [analyse class-decl class-env all-supers method] + "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" + (|let [[?cname ?cparams] class-decl + class-type (&/$HostT ?cname (&/|map &/|second class-env))] + (|case method + (&/$ConstructorMethodSyntax =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env (&/|++ class-env method-env)] + :let [output-type &/$UnitT] + =ctor-args (&/map% (fn [ctor-arg] + (|do [:let [[ca-type ca-term] ctor-arg] + =ca-type (generic-class->type full-env ca-type) + =ca-term (&&/analyse-1 analyse =ca-type ca-term)] + (return (&/T [ca-type =ca-term])))) + ?ctor-args) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) + + (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env (&/|++ class-env method-env)] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$OverridenMethodSyntax ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [super-env (gen-super-env class-env all-supers ?class-decl) + method-env (make-type-env ?gvars) + :let [full-env (&/|++ super-env method-env)] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$StaticMethodSyntax ?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env method-env] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs)))))] + (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$AbstractMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (return (&/$AbstractMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) + + (&/$NativeMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (return (&/$NativeMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) + ))) + +(defn ^:private mandatory-methods [supers] + (|do [class-loader &/loader] + (&/flat-map% (partial &host/abstract-methods class-loader) supers))) + +(defn ^:private check-method-completion [supers methods] + "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux Null))" + (|do [abstract-methods (mandatory-methods supers) + :let [methods-map (&/fold (fn [mmap mentry] + (|case mentry + (&/$ConstructorMethodAnalysis _) + mmap + + (&/$VirtualMethodAnalysis _) + mmap + + (&/$OverridenMethodAnalysis =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) + (update-in mmap [=name] (fn [old-inputs] (if old-inputs (conj old-inputs =inputs) [=inputs]))) + + (&/$StaticMethodAnalysis _) + mmap + + (&/$AbstractMethodSyntax _) + mmap + + (&/$NativeMethodSyntax _) + mmap + )) + {} + methods) + missing-method (&/fold (fn [missing abs-meth] + (or missing + (|let [[am-name am-inputs] abs-meth] + (if-let [meth-struct (get methods-map am-name)] + (if (some (fn [=inputs] + (and (= (&/|length =inputs) (&/|length am-inputs)) + (&/fold2 (fn [prev mi ai] + (|let [[iname itype] mi] + (and prev (= (generic-class->simple-class itype) ai)))) + true + =inputs am-inputs))) + meth-struct) + nil + abs-meth) + abs-meth)))) + nil + abstract-methods)]] + (if (nil? missing-method) + (return nil) + (|let [[am-name am-inputs] missing-method] + (&/fail-with-loc (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) + +(defn ^:private analyse-field [analyse gtype-env field] + "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))" + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (|do [=gtype (&host-type/instance-gtype &type/existential gtype-env ?gclass) + =value (&&/analyse-1 analyse =gtype ?value)] + (return (&/$ConstantFieldAnalysis ?name ?anns ?gclass =value))) + + (&/$VariableFieldSyntax ?name ?privacy-modifier ?state-modifier ?anns ?type) + (return (&/$VariableFieldAnalysis ?name ?privacy-modifier ?state-modifier ?anns ?type)) + )) + +(do-template [ ] + (let [output-type (&/$HostT &/$Nil)] + (defn [analyse exo-type _?value] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + =value (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value) (&/|list)))))))) + + ^:private analyse-jvm-d2f "d2f" "java.lang.Double" "java.lang.Float" + ^:private analyse-jvm-d2i "d2i" "java.lang.Double" "java.lang.Integer" + ^:private analyse-jvm-d2l "d2l" "java.lang.Double" "java.lang.Long" + + ^:private analyse-jvm-f2d "f2d" "java.lang.Float" "java.lang.Double" + ^:private analyse-jvm-f2i "f2i" "java.lang.Float" "java.lang.Integer" + ^:private analyse-jvm-f2l "f2l" "java.lang.Float" "java.lang.Long" + + ^:private analyse-jvm-i2b "i2b" "java.lang.Integer" "java.lang.Byte" + ^:private analyse-jvm-i2c "i2c" "java.lang.Integer" "java.lang.Character" + ^:private analyse-jvm-i2d "i2d" "java.lang.Integer" "java.lang.Double" + ^:private analyse-jvm-i2f "i2f" "java.lang.Integer" "java.lang.Float" + ^:private analyse-jvm-i2l "i2l" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-i2s "i2s" "java.lang.Integer" "java.lang.Short" + + ^:private analyse-jvm-l2d "l2d" "java.lang.Long" "java.lang.Double" + ^:private analyse-jvm-l2f "l2f" "java.lang.Long" "java.lang.Float" + ^:private analyse-jvm-l2i "l2i" "java.lang.Long" "java.lang.Integer" + ^:private analyse-jvm-l2s "l2i" "java.lang.Long" "java.lang.Short" + ^:private analyse-jvm-l2b "l2i" "java.lang.Long" "java.lang.Byte" + + ^:private analyse-jvm-c2b "c2b" "java.lang.Character" "java.lang.Byte" + ^:private analyse-jvm-c2s "c2s" "java.lang.Character" "java.lang.Short" + ^:private analyse-jvm-c2i "c2i" "java.lang.Character" "java.lang.Integer" + ^:private analyse-jvm-c2l "c2l" "java.lang.Character" "java.lang.Long" + + ^:private analyse-jvm-s2l "s2l" "java.lang.Short" "java.lang.Long" + + ^:private analyse-jvm-b2l "b2l" "java.lang.Byte" "java.lang.Long" + ) + +(do-template [ ] + (let [output-type (&/$HostT &/$Nil)] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?value1 (&/$Cons ?value2 (&/$Nil))) ?values] + =value1 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value1) + =value2 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value2) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value1 =value2) (&/|list)))))))) + + ^:private analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ixor "ixor" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ishl "ishl" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ishr "ishr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-iushr "iushr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + + ^:private analyse-jvm-land "land" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lor "lor" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lxor "lxor" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lshl "lshl" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-lshr "lshr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-lushr "lushr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ) + +(do-template [ ] + (let [input-type (&/$HostT &/$Nil) + output-type (&/$HostT &/$Nil)] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse input-type x) + =y (&&/analyse-1 analyse input-type y) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =x =y) (&/|list)))))))) + + ^:private analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-imul "imul" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-idiv "idiv" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-irem "irem" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ieq "ieq" "java.lang.Integer" "java.lang.Boolean" + ^:private analyse-jvm-ilt "ilt" "java.lang.Integer" "java.lang.Boolean" + ^:private analyse-jvm-igt "igt" "java.lang.Integer" "java.lang.Boolean" + + ^:private analyse-jvm-ceq "ceq" "java.lang.Character" "java.lang.Boolean" + ^:private analyse-jvm-clt "clt" "java.lang.Character" "java.lang.Boolean" + ^:private analyse-jvm-cgt "cgt" "java.lang.Character" "java.lang.Boolean" + + ^:private analyse-jvm-ladd "ladd" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lsub "lsub" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lmul "lmul" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-ldiv "ldiv" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lrem "lrem" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-leq "leq" "java.lang.Long" "java.lang.Boolean" + ^:private analyse-jvm-llt "llt" "java.lang.Long" "java.lang.Boolean" + ^:private analyse-jvm-lgt "lgt" "java.lang.Long" "java.lang.Boolean" + + ^:private analyse-jvm-fadd "fadd" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fsub "fsub" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fmul "fmul" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fdiv "fdiv" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-frem "frem" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-feq "feq" "java.lang.Float" "java.lang.Boolean" + ^:private analyse-jvm-flt "flt" "java.lang.Float" "java.lang.Boolean" + ^:private analyse-jvm-fgt "fgt" "java.lang.Float" "java.lang.Boolean" + + ^:private analyse-jvm-dadd "dadd" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-dsub "dsub" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-dmul "dmul" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-ddiv "ddiv" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-drem "drem" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-deq "deq" "java.lang.Double" "java.lang.Boolean" + ^:private analyse-jvm-dlt "dlt" "java.lang.Double" "java.lang.Boolean" + ^:private analyse-jvm-dgt "dgt" "java.lang.Double" "java.lang.Boolean" + ) + +(let [length-type &type/Nat + idx-type &type/Nat] + (do-template [ ] + (let [elem-type (&/$HostT &/$Nil) + array-type (&/$HostT &/$Nil)] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons length (&/$Nil)) ?values] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =length) (&/|list))))))) + + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type elem-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx) (&/|list))))))) + + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse elem-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx =elem) (&/|list))))))) + ) + + "java.lang.Boolean" "[Z" ^:private analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore" + "java.lang.Byte" "[B" ^:private analyse-jvm-bnewarray "bnewarray" analyse-jvm-baload "baload" analyse-jvm-bastore "bastore" + "java.lang.Short" "[S" ^:private analyse-jvm-snewarray "snewarray" analyse-jvm-saload "saload" analyse-jvm-sastore "sastore" + "java.lang.Integer" "[I" ^:private analyse-jvm-inewarray "inewarray" analyse-jvm-iaload "iaload" analyse-jvm-iastore "iastore" + "java.lang.Long" "[J" ^:private analyse-jvm-lnewarray "lnewarray" analyse-jvm-laload "laload" analyse-jvm-lastore "lastore" + "java.lang.Float" "[F" ^:private analyse-jvm-fnewarray "fnewarray" analyse-jvm-faload "faload" analyse-jvm-fastore "fastore" + "java.lang.Double" "[D" ^:private analyse-jvm-dnewarray "dnewarray" analyse-jvm-daload "daload" analyse-jvm-dastore "dastore" + "java.lang.Character" "[C" ^:private analyse-jvm-cnewarray "cnewarray" analyse-jvm-caload "caload" analyse-jvm-castore "castore" + )) + +(defn ^:private array-class? [class-name] + (or (= &host-type/array-data-tag class-name) + (case class-name + ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") true + ;; else + false))) + +(let [length-type &type/Nat + idx-type &type/Nat] + (defn ^:private analyse-jvm-anewarray [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$TextS _gclass)] (&/$Cons length (&/$Nil))) ?values] + gclass (&reader/with-source "jvm-anewarray" _gclass + &&a-parser/parse-gclass) + gtype-env &/get-type-env + =gclass (&host-type/instance-gtype &type/existential gtype-env gclass) + :let [array-type (&/$HostT &host-type/array-data-tag (&/|list =gclass))] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) + + (defn ^:private analyse-jvm-aaload [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type inner-arr-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list))))))) + + (defn ^:private analyse-jvm-aastore [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] + =array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse inner-arr-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) + +(defn ^:private analyse-jvm-arraylength [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Nil)) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list)) + ))))) + +(defn ^:private analyse-jvm-null? [analyse exo-type ?values] + (|do [:let [(&/$Cons object (&/$Nil)) ?values] + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "null?"]) (&/|list =object) (&/|list))))))) + +(defn ^:private analyse-jvm-null [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + :let [output-type (&/$HostT &host-type/null-data-tag &/$Nil)] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list))))))) + +(defn analyse-jvm-synchronized [analyse exo-type ?values] + (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values] + =monitor (&&/analyse-1+ analyse ?monitor) + _ (ensure-object (&&/expr-type* =monitor)) + =expr (&&/analyse-1 analyse exo-type ?expr) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "synchronized"]) (&/|list =monitor =expr) (&/|list))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?monitor (&/$Nil)) ?values] + =monitor (&&/analyse-1+ analyse ?monitor) + _ (ensure-object (&&/expr-type* =monitor)) + :let [output-type &/$UnitT] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =monitor) (&/|list))))))) + + ^:private analyse-jvm-monitorenter "monitorenter" + ^:private analyse-jvm-monitorexit "monitorexit" + ) + +(defn ^:private analyse-jvm-throw [analyse exo-type ?values] + (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values] + =ex (&&/analyse-1+ analyse ?ex) + _ (&type/check (&/$HostT "java.lang.Throwable" &/$Nil) (&&/expr-type* =ex)) + [throw-class throw-params] (ensure-object (&&/expr-type* =ex)) + _ (ensure-catching (&/|list throw-class)) + _cursor &/cursor + _ (&type/check exo-type &type/Bottom)] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list))))))) + +(defn ^:private analyse-jvm-getstatic [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Nil) ?values] + class-loader &/loader + [gvars gtype] (&host/lookup-static-field class-loader !class! field) + =type (&host-type/instance-param &type/existential &/$Nil gtype) + :let [output-type =type] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type))))))) + +(defn ^:private analyse-jvm-getfield [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Nil)) ?values] + class-loader &/loader + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + [gvars gtype] (&host/lookup-field class-loader !class! field) + =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) + :let [output-type =type] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type))))))) + +(defn ^:private analyse-jvm-putstatic [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons value (&/$Nil)) ?values] + class-loader &/loader + [gvars gtype] (&host/lookup-static-field class-loader !class! field) + :let [gclass (&host-type/gtype->gclass gtype)] + =type (&host-type/instance-param &type/existential &/$Nil gtype) + =value (&&/analyse-1 analyse =type value) + :let [output-type &/$UnitT] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass))))))) + +(defn ^:private analyse-jvm-putfield [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values] + class-loader &/loader + =object (&&/analyse-1+ analyse object) + :let [obj-type (&&/expr-type* =object)] + _ (ensure-object obj-type) + [gvars gtype] (&host/lookup-field class-loader !class! field) + :let [gclass (&host-type/gtype->gclass gtype)] + =type (analyse-field-access-helper obj-type gvars gtype) + =value (&&/analyse-1 analyse =type value) + :let [output-type &/$UnitT] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type))))))) + +(defn ^:private analyse-method-call-helper [analyse exo-type gret gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =arg-types (&/map% &type/show-type+ arg-types) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + =gret (&host-type/instance-param &type/existential gtype-env gret) + _ (&type/check exo-type (as-otype+ =gret))] + (return (&/T [=gret =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [(&/$VarT _id) $var + gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-method-call-helper analyse exo-type gret gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(let [dummy-type-param (&/$HostT "java.lang.Object" &/$Nil)] + (do-template [ ] + (defn [analyse exo-type class method classes ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object args) ?values] + class-loader &/loader + _ (try (assert! (let [=class (Class/forName !class! true class-loader)] + (= (.isInterface =class))) + (if + (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") + (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) + (catch Exception e + (&/fail-with-loc (str "[Analyser Error] Unknown class: " class)))) + [gret exceptions parent-gvars gvars gargs] (if (= "" method) + (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) + (&host/lookup-virtual-method class-loader !class! method classes)) + _ (ensure-catching exceptions) + =object (&&/analyse-1+ analyse object) + [sub-class sub-params] (ensure-object (&&/expr-type* =object)) + (&/$HostT super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class) + !class! + sub-class) + sub-params) + :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) + (&/|table) + parent-gvars + super-params*)] + [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/$Cons =object =args) (&/|list class method classes output-type gret))))))) + + ^:private analyse-jvm-invokevirtual "invokevirtual" false + ^:private analyse-jvm-invokespecial "invokespecial" false + ^:private analyse-jvm-invokeinterface "invokeinterface" true + )) + +(defn ^:private analyse-jvm-invokestatic [analyse exo-type class method classes ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] + class-loader &/loader + [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader !class! method classes) + _ (ensure-catching exceptions) + :let [gtype-env (&/|table)] + [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret))))))) + +(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] + (return (&/T [(make-gtype gtype gtype-vars*) + =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(defn ^:private analyse-jvm-new [analyse exo-type class classes ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] + class-loader &/loader + [exceptions gvars gargs] (&host/lookup-constructor class-loader !class! classes) + _ (ensure-catching exceptions) + [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes))))))) + +(defn ^:private analyse-jvm-try [analyse exo-type ?values] + (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values] + =body (with-catches (&/|list "java.lang.Exception") + (&&/analyse-1 analyse exo-type ?body)) + =catch (&&/analyse-1 analyse (&/$LambdaT (&/$HostT "java.lang.Exception" &/$Nil) exo-type) ?catch) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "try"]) (&/|list =body =catch) (&/|list))))))) + +(defn ^:private analyse-jvm-instanceof [analyse exo-type class ?values] + (|do [:let [(&/$Cons object (&/$Nil)) ?values] + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class))))))) + +(defn ^:private analyse-jvm-load-class [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$TextS _class-name)] (&/$Nil)) ?values] + ^ClassLoader class-loader &/loader + _ (try (do (.loadClass class-loader _class-name) + (return nil)) + (catch Exception e + (&/fail-with-loc (str "[Analyser Error] Unknown class: " _class-name)))) + :let [output-type (&/$HostT "java.lang.Class" (&/|list (&/$HostT _class-name (&/|list))))] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type))))))) + +(let [length-type &type/Nat + idx-type &type/Nat] + (defn ^:private analyse-array-new [analyse exo-type ?values] + (|do [:let [(&/$Cons length (&/$Nil)) ?values] + :let [gclass (&/$GenericClass "java.lang.Object" (&/|list)) + array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))] + gtype-env &/get-type-env + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) + + (defn ^:private analyse-array-get [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list))))))) + + (defn ^:private analyse-array-remove [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _cursor &/cursor + :let [=elem (&&/|meta inner-arr-type _cursor + (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))] + _ (&type/check exo-type array-type)] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) + +(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods] + (|do [module &/get-module-name + _ (compile-interface interface-decl supers =anns =methods) + :let [_ (println 'INTERFACE (str module "." (&/|first interface-decl)))] + _cursor &/cursor] + (return (&/|list (&&/|meta &/$UnitT _cursor + (&&/$tuple (&/|list))))))) + +(defn ^:private analyse-jvm-class [analyse compile-class class-decl super-class interfaces =inheritance-modifier =anns ?fields methods] + (&/with-closure + (|do [module &/get-module-name + :let [[?name ?params] class-decl + full-name (str (string/replace module "/" ".") "." ?name) + class-decl* (&/T [full-name ?params]) + all-supers (&/$Cons super-class interfaces)] + class-env (make-type-env ?params) + =fields (&/map% (partial analyse-field analyse class-env) ?fields) + _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) + =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) + _ (check-method-completion all-supers =methods) + _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None) + _ &/pop-dummy-name + :let [_ (println 'CLASS full-name)] + _cursor &/cursor] + (return (&/|list (&&/|meta &/$UnitT _cursor + (&&/$tuple (&/|list)))))))) + +(defn ^:private captured-source [env-entry] + (|case env-entry + [name [_ (&&/$captured _ _ source)]] + source)) + +(let [default- (&/$ConstructorMethodSyntax (&/T [&/$PublicPM + false + &/$Nil + &/$Nil + &/$Nil + &/$Nil + &/$Nil + (&/$TupleS &/$Nil)])) + captured-slot-class "java.lang.Object" + captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] + (defn ^:private analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] + (&/with-closure + (|do [module &/get-module-name + scope &/get-scope-name + :let [name (->> scope &/|reverse &/|tail &host/location) + class-decl (&/T [name &/$Nil]) + anon-class (str (string/replace module "/" ".") "." name) + anon-class-type (&/$HostT anon-class &/$Nil)] + =ctor-args (&/map% (fn [ctor-arg] + (|let [[arg-type arg-term] ctor-arg] + (|do [=arg-term (&&/analyse-1+ analyse arg-term)] + (return (&/T [arg-type =arg-term]))))) + ctor-args) + _ (->> methods + (&/$Cons default-) + (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) + :let [all-supers (&/$Cons super-class interfaces) + class-env &/$Nil] + =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) + _ (check-method-completion all-supers =methods) + =captured &&env/captured-vars + :let [=fields (&/|map (fn [^objects idx+capt] + (|let [[idx _] idx+capt] + (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx) + &/$PublicPM + &/$FinalSM + &/$Nil + captured-slot-type))) + (&/enumerate =captured))] + :let [sources (&/|map captured-source =captured)] + _ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)) + _ &/pop-dummy-name + _cursor &/cursor] + (return (&/|list (&&/|meta anon-class-type _cursor + (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class))) + ))) + )))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] + =mask (&&/analyse-1 analyse &type/Nat mask) + =input (&&/analyse-1 analyse &type/Nat input) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" ]) (&/|list =input =mask) (&/|list))))))) + + ^:private analyse-bit-and "and" + ^:private analyse-bit-or "or" + ^:private analyse-bit-xor "xor" + ) + +(defn ^:private analyse-bit-count [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Nil)) ?values] + =input (&&/analyse-1 analyse &type/Nat input) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] + =shift (&&/analyse-1 analyse &type/Nat shift) + =input (&&/analyse-1 analyse input) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" ]) (&/|list =input =shift) (&/|list))))))) + + ^:private analyse-bit-shift-left "shift-left" &type/Nat + ^:private analyse-bit-shift-right "shift-right" &type/Int + ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat + ) + +(defn ^:private analyse-lux-== [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] + =left (&&/analyse-1 analyse $var left) + =right (&&/analyse-1 analyse $var right) + _ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse x) + =y (&&/analyse-1 analyse y) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat + ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat + ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat + ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat + ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat + ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool + ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool + + ^:private analyse-frac-add ["frac" "+"] &type/Frac &type/Frac + ^:private analyse-frac-sub ["frac" "-"] &type/Frac &type/Frac + ^:private analyse-frac-mul ["frac" "*"] &type/Frac &type/Frac + ^:private analyse-frac-div ["frac" "/"] &type/Frac &type/Frac + ^:private analyse-frac-rem ["frac" "%"] &type/Frac &type/Frac + ^:private analyse-frac-eq ["frac" "="] &type/Frac &type/Bool + ^:private analyse-frac-lt ["frac" "<"] &type/Frac &type/Bool + ) + +(defn ^:private analyse-frac-scale [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse &type/Frac x) + =y (&&/analyse-1 analyse &type/Nat y) + _ (&type/check exo-type &type/Frac) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Frac _cursor + (&&/$proc (&/T ["frac" "scale"]) (&/|list =x =y) (&/|list))))))) + +(do-template [ ] + (do (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Text _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + (let [decode-type (&/$AppT &type/Maybe )] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse &type/Text x) + _ (&type/check exo-type decode-type) + _cursor &/cursor] + (return (&/|list (&&/|meta decode-type _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) + + ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat + ^:private analyse-frac-encode ["frac" "encode"] ^:private analyse-frac-decode ["frac" "decode"] &type/Frac + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list) (&/|list))))))) + + ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] + ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + + ^:private analyse-frac-min-value &type/Frac ["frac" "min-value"] + ^:private analyse-frac-max-value &type/Frac ["frac" "max-value"] + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] + ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] + ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] + ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] + + ^:private analyse-frac-to-real &type/Frac &type/Real ["frac" "to-real"] + ^:private analyse-real-to-frac &type/Real &type/Frac ["real" "to-frac"] + ) + +(defn analyse-host [analyse exo-type compilers category proc ?values] + (|let [[_ _ compile-class compile-interface] compilers] + (case category + "lux" + (case proc + "==" (analyse-lux-== analyse exo-type ?values)) + + "bit" + (case proc + "count" (analyse-bit-count analyse exo-type ?values) + "and" (analyse-bit-and analyse exo-type ?values) + "or" (analyse-bit-or analyse exo-type ?values) + "xor" (analyse-bit-xor analyse exo-type ?values) + "shift-left" (analyse-bit-shift-left analyse exo-type ?values) + "shift-right" (analyse-bit-shift-right analyse exo-type ?values) + "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) + + "array" + (case proc + "new" (analyse-array-new analyse exo-type ?values) + "get" (analyse-array-get analyse exo-type ?values) + "put" (analyse-jvm-aastore analyse exo-type ?values) + "remove" (analyse-array-remove analyse exo-type ?values) + "size" (analyse-jvm-arraylength analyse exo-type ?values)) + + "nat" + (case proc + "+" (analyse-nat-add analyse exo-type ?values) + "-" (analyse-nat-sub analyse exo-type ?values) + "*" (analyse-nat-mul analyse exo-type ?values) + "/" (analyse-nat-div analyse exo-type ?values) + "%" (analyse-nat-rem analyse exo-type ?values) + "=" (analyse-nat-eq analyse exo-type ?values) + "<" (analyse-nat-lt analyse exo-type ?values) + "encode" (analyse-nat-encode analyse exo-type ?values) + "decode" (analyse-nat-decode analyse exo-type ?values) + "min-value" (analyse-nat-min-value analyse exo-type ?values) + "max-value" (analyse-nat-max-value analyse exo-type ?values) + "to-int" (analyse-nat-to-int analyse exo-type ?values) + "to-char" (analyse-nat-to-char analyse exo-type ?values) + ) + + "frac" + (case proc + "+" (analyse-frac-add analyse exo-type ?values) + "-" (analyse-frac-sub analyse exo-type ?values) + "*" (analyse-frac-mul analyse exo-type ?values) + "/" (analyse-frac-div analyse exo-type ?values) + "%" (analyse-frac-rem analyse exo-type ?values) + "=" (analyse-frac-eq analyse exo-type ?values) + "<" (analyse-frac-lt analyse exo-type ?values) + "encode" (analyse-frac-encode analyse exo-type ?values) + "decode" (analyse-frac-decode analyse exo-type ?values) + "min-value" (analyse-frac-min-value analyse exo-type ?values) + "max-value" (analyse-frac-max-value analyse exo-type ?values) + "to-real" (analyse-frac-to-real analyse exo-type ?values) + "scale" (analyse-frac-scale analyse exo-type ?values) + ) + + "int" + (case proc + "to-nat" (analyse-int-to-nat analyse exo-type ?values) + ) + + "real" + (case proc + "to-frac" (analyse-real-to-frac analyse exo-type ?values) + ) + + "char" + (case proc + "to-nat" (analyse-char-to-nat analyse exo-type ?values) + ) + + "jvm" + (case proc + "synchronized" (analyse-jvm-synchronized analyse exo-type ?values) + "load-class" (analyse-jvm-load-class analyse exo-type ?values) + "try" (analyse-jvm-try analyse exo-type ?values) + "throw" (analyse-jvm-throw analyse exo-type ?values) + "monitorenter" (analyse-jvm-monitorenter analyse exo-type ?values) + "monitorexit" (analyse-jvm-monitorexit analyse exo-type ?values) + "null?" (analyse-jvm-null? analyse exo-type ?values) + "null" (analyse-jvm-null analyse exo-type ?values) + "anewarray" (analyse-jvm-anewarray analyse exo-type ?values) + "aaload" (analyse-jvm-aaload analyse exo-type ?values) + "aastore" (analyse-jvm-aastore analyse exo-type ?values) + "arraylength" (analyse-jvm-arraylength analyse exo-type ?values) + "znewarray" (analyse-jvm-znewarray analyse exo-type ?values) + "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) + "snewarray" (analyse-jvm-snewarray analyse exo-type ?values) + "inewarray" (analyse-jvm-inewarray analyse exo-type ?values) + "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) + "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) + "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) + "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) + "iadd" (analyse-jvm-iadd analyse exo-type ?values) + "isub" (analyse-jvm-isub analyse exo-type ?values) + "imul" (analyse-jvm-imul analyse exo-type ?values) + "idiv" (analyse-jvm-idiv analyse exo-type ?values) + "irem" (analyse-jvm-irem analyse exo-type ?values) + "ieq" (analyse-jvm-ieq analyse exo-type ?values) + "ilt" (analyse-jvm-ilt analyse exo-type ?values) + "igt" (analyse-jvm-igt analyse exo-type ?values) + "ceq" (analyse-jvm-ceq analyse exo-type ?values) + "clt" (analyse-jvm-clt analyse exo-type ?values) + "cgt" (analyse-jvm-cgt analyse exo-type ?values) + "ladd" (analyse-jvm-ladd analyse exo-type ?values) + "lsub" (analyse-jvm-lsub analyse exo-type ?values) + "lmul" (analyse-jvm-lmul analyse exo-type ?values) + "ldiv" (analyse-jvm-ldiv analyse exo-type ?values) + "lrem" (analyse-jvm-lrem analyse exo-type ?values) + "leq" (analyse-jvm-leq analyse exo-type ?values) + "llt" (analyse-jvm-llt analyse exo-type ?values) + "lgt" (analyse-jvm-lgt analyse exo-type ?values) + "fadd" (analyse-jvm-fadd analyse exo-type ?values) + "fsub" (analyse-jvm-fsub analyse exo-type ?values) + "fmul" (analyse-jvm-fmul analyse exo-type ?values) + "fdiv" (analyse-jvm-fdiv analyse exo-type ?values) + "frem" (analyse-jvm-frem analyse exo-type ?values) + "feq" (analyse-jvm-feq analyse exo-type ?values) + "flt" (analyse-jvm-flt analyse exo-type ?values) + "fgt" (analyse-jvm-fgt analyse exo-type ?values) + "dadd" (analyse-jvm-dadd analyse exo-type ?values) + "dsub" (analyse-jvm-dsub analyse exo-type ?values) + "dmul" (analyse-jvm-dmul analyse exo-type ?values) + "ddiv" (analyse-jvm-ddiv analyse exo-type ?values) + "drem" (analyse-jvm-drem analyse exo-type ?values) + "deq" (analyse-jvm-deq analyse exo-type ?values) + "dlt" (analyse-jvm-dlt analyse exo-type ?values) + "dgt" (analyse-jvm-dgt analyse exo-type ?values) + "iand" (analyse-jvm-iand analyse exo-type ?values) + "ior" (analyse-jvm-ior analyse exo-type ?values) + "ixor" (analyse-jvm-ixor analyse exo-type ?values) + "ishl" (analyse-jvm-ishl analyse exo-type ?values) + "ishr" (analyse-jvm-ishr analyse exo-type ?values) + "iushr" (analyse-jvm-iushr analyse exo-type ?values) + "land" (analyse-jvm-land analyse exo-type ?values) + "lor" (analyse-jvm-lor analyse exo-type ?values) + "lxor" (analyse-jvm-lxor analyse exo-type ?values) + "lshl" (analyse-jvm-lshl analyse exo-type ?values) + "lshr" (analyse-jvm-lshr analyse exo-type ?values) + "lushr" (analyse-jvm-lushr analyse exo-type ?values) + "d2f" (analyse-jvm-d2f analyse exo-type ?values) + "d2i" (analyse-jvm-d2i analyse exo-type ?values) + "d2l" (analyse-jvm-d2l analyse exo-type ?values) + "f2d" (analyse-jvm-f2d analyse exo-type ?values) + "f2i" (analyse-jvm-f2i analyse exo-type ?values) + "f2l" (analyse-jvm-f2l analyse exo-type ?values) + "i2b" (analyse-jvm-i2b analyse exo-type ?values) + "i2c" (analyse-jvm-i2c analyse exo-type ?values) + "i2d" (analyse-jvm-i2d analyse exo-type ?values) + "i2f" (analyse-jvm-i2f analyse exo-type ?values) + "i2l" (analyse-jvm-i2l analyse exo-type ?values) + "i2s" (analyse-jvm-i2s analyse exo-type ?values) + "l2d" (analyse-jvm-l2d analyse exo-type ?values) + "l2f" (analyse-jvm-l2f analyse exo-type ?values) + "l2i" (analyse-jvm-l2i analyse exo-type ?values) + "l2s" (analyse-jvm-l2s analyse exo-type ?values) + "l2b" (analyse-jvm-l2b analyse exo-type ?values) + "c2b" (analyse-jvm-c2b analyse exo-type ?values) + "c2s" (analyse-jvm-c2s analyse exo-type ?values) + "c2i" (analyse-jvm-c2i analyse exo-type ?values) + "c2l" (analyse-jvm-c2l analyse exo-type ?values) + "b2l" (analyse-jvm-b2l analyse exo-type ?values) + "s2l" (analyse-jvm-s2l analyse exo-type ?values) + ;; else + (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])) + (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)] + (&reader/with-source "interface" _def-code + (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] + (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods)))) + + (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)] + (&reader/with-source "class" _def-code + (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] + (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods)))) + + (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)] + (&reader/with-source "anon-class" _def-code + (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] + (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods)))) + + (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)] + (analyse-jvm-instanceof analyse exo-type _class ?values)) + + (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] + (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getfield analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putfield analyse exo-type _class _field ?values)))) + + ;; else + (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))))) diff --git a/luxc/src/lux/analyser/lambda.clj b/luxc/src/lux/analyser/lambda.clj new file mode 100644 index 000000000..b47b803d0 --- /dev/null +++ b/luxc/src/lux/analyser/lambda.clj @@ -0,0 +1,33 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.lambda + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return fail |case]] + [host :as &host]) + (lux.analyser [base :as &&] + [env :as &env]))) + +;; [Resource] +(defn with-lambda [self self-type arg arg-type body] + (&/with-closure + (|do [scope-name &/get-scope-name] + (&env/with-local self self-type + (&env/with-local arg arg-type + (|do [=return body + =captured &env/captured-vars] + (return (&/T [scope-name =captured =return])))))))) + +(defn close-over [scope name register frame] + (|let [[[register-type register-cursor] _] register + register* (&&/|meta register-type register-cursor + (&&/$captured (&/T [scope + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) + register])))] + (&/T [register* (&/update$ &/$closure #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) + frame)]))) diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj new file mode 100644 index 000000000..1d46c2b60 --- /dev/null +++ b/luxc/src/lux/analyser/lux.clj @@ -0,0 +1,736 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.lux + (:require (clojure [template :refer [do-template]] + [set :as set]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return return* fail fail* |let |list |case]] + [parser :as &parser] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &&] + [lambda :as &&lambda] + [case :as &&case] + [env :as &&env] + [module :as &&module] + [record :as &&record] + [meta :as &&meta]))) + +;; [Utils] +;; TODO: Walk the type to set up the bound-type, instead of doing a +;; rough calculation like this one. +(defn ^:private count-univq [type] + "(-> Type Int)" + (|case type + (&/$UnivQ env type*) + (inc (count-univq type*)) + + _ + 0)) + +;; TODO: This technique won't work if the body of the type contains +;; nested quantifications that cannot be directly counted. +(defn ^:private next-bound-type [type] + "(-> Type Type)" + (&/$BoundT (->> (count-univq type) (* 2) (+ 1)))) + +(defn ^:private embed-inferred-input [input output] + "(-> Type Type Type)" + (|case output + (&/$UnivQ env output*) + (&/$UnivQ env (embed-inferred-input input output*)) + + _ + (&/$LambdaT input output))) + +;; [Exports] +(defn analyse-unit [analyse ?exo-type] + (|do [_cursor &/cursor + _ (&type/check ?exo-type &/$UnitT)] + (return (&/|list (&&/|meta ?exo-type _cursor + (&&/$tuple (&/|list))))))) + +(defn analyse-tuple [analyse ?exo-type ?elems] + (|case ?elems + (&/$Nil) + (analyse-unit analyse (|case ?exo-type + (&/$Left exo-type) exo-type + (&/$Right exo-type) exo-type)) + + (&/$Cons ?elem (&/$Nil)) + (analyse (|case ?exo-type + (&/$Left exo-type) exo-type + (&/$Right exo-type) exo-type) + ?elem) + + _ + (|case ?exo-type + (&/$Left exo-type) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left exo-type**) ?elems)) + =var (&type/resolve-type $var) + inferred-type (|case =var + (&/$VarT iid) + (|do [:let [=var* (next-bound-type tuple-type)] + _ (&type/set-var iid =var*) + tuple-type* (&type/clean $var tuple-type)] + (return (&/$UnivQ &/$Nil tuple-type*))) + + _ + (&type/clean $var tuple-type))] + (return (&/|list (&&/|meta inferred-type tuple-cursor + tuple-analysis)))))) + + _ + (analyse-tuple analyse (&/$Right exo-type*) ?elems))) + + (&/$Right exo-type) + (|do [unknown? (&type/unknown? exo-type)] + (if unknown? + (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] + (return =analysis)) + ?elems) + _ (&type/check exo-type (|case (->> (&/|map &&/expr-type* =elems) (&/|reverse)) + (&/$Cons last prevs) + (&/fold (fn [right left] (&/$ProdT left right)) + last prevs))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$tuple =elems) + )))) + (|do [exo-type* (&type/actual-type exo-type)] + (&/with-attempt + (|case exo-type* + (&/$ProdT _) + (|let [num-elems (&/|length ?elems) + [_shorter _tuple-types] (&type/tuple-types-for num-elems exo-type*)] + (if (= num-elems _shorter) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + _tuple-types + ?elems) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$tuple =elems) + )))) + (|do [=direct-elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) + (&/|take (dec _shorter) _tuple-types) + (&/|take (dec _shorter) ?elems)) + =indirect-elems (analyse-tuple analyse + (&/$Right (&/|last _tuple-types)) + (&/|drop (dec _shorter) ?elems)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$tuple (&/|++ =direct-elems =indirect-elems)) + )))))) + + (&/$ExQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)) + =tuple-analysis (&&/clean-analysis $var (&&/|meta exo-type tuple-cursor + tuple-analysis))] + (return (&/|list =tuple-analysis))))) + + (&/$UnivQ _) + (|do [$var &type/existential + :let [(&/$ExT $var-id) $var] + exo-type** (&type/apply-type exo-type* $var) + [[tuple-type tuple-cursor] tuple-analysis] (&/with-scope-type-var $var-id + (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)))] + (return (&/|list (&&/|meta exo-type tuple-cursor + tuple-analysis)))) + + _ + (&/fail-with-loc (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))) + ) + (fn [err] + (&/fail-with-loc (str err "\n" "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type))))))))) + )) + +(defn ^:private analyse-variant-body [analyse exo-type ?values] + (|do [_cursor &/cursor + output (|case ?values + (&/$Nil) + (analyse-unit analyse exo-type) + + (&/$Cons ?value (&/$Nil)) + (analyse exo-type ?value) + + _ + (analyse-tuple analyse (&/$Right exo-type) ?values))] + (|case output + (&/$Cons x (&/$Nil)) + (return x) + + _ + (&/fail-with-loc "[Analyser Error] Can't expand to other than 1 element.")))) + +(defn analyse-variant [analyse ?exo-type idx is-last? ?values] + (|case ?exo-type + (&/$Left exo-type) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/$Left exo-type**) idx is-last? ?values)) + =var (&type/resolve-type $var) + inferred-type (|case =var + (&/$VarT iid) + (|do [:let [=var* (next-bound-type variant-type)] + _ (&type/set-var iid =var*) + variant-type* (&type/clean $var variant-type)] + (return (&/$UnivQ &/$Nil variant-type*))) + + _ + (&type/clean $var variant-type))] + (return (&/|list (&&/|meta inferred-type variant-cursor + variant-analysis)))))) + + _ + (analyse-variant analyse (&/$Right exo-type*) idx is-last? ?values))) + + (&/$Right exo-type) + (|do [exo-type* (|case exo-type + (&/$VarT ?id) + (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] + (&type/actual-type exo-type*)) + (|do [_ (&type/set-var ?id &type/Type)] + (&type/actual-type &type/Type)))) + + _ + (&type/actual-type exo-type))] + (&/with-attempt + (|case exo-type* + (&/$SumT _) + (|do [vtype (&type/sum-at idx exo-type*) + :let [num-variant-types (&/|length (&type/flatten-sum exo-type*)) + is-last?* (if (nil? is-last?) + (= idx (dec num-variant-types)) + is-last?)] + =value (analyse-variant-body analyse vtype ?values) + _cursor &/cursor] + (if (= 1 num-variant-types) + (return (&/|list =value)) + (return (&/|list (&&/|meta exo-type _cursor (&&/$variant idx is-last?* =value)))) + )) + + (&/$UnivQ _) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var)] + (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)) + + (&/$ExQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + =exprs (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)] + (&/map% (partial &&/clean-analysis $var) =exprs)))) + + _ + (&/fail-with-loc (str "[Analyser Error] Can't create variant if the expected type is " (&type/show-type exo-type*) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) + (fn [err] + (|case exo-type + (&/$VarT ?id) + (|do [=exo-type (&type/deref ?id)] + (&/fail-with-loc (str err "\n" "[Analyser Error] Can't create variant if the expected type is " (&type/show-type =exo-type) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) + + _ + (&/fail-with-loc (str err "\n" "[Analyser Error] Can't create variant if the expected type is " (&type/show-type exo-type) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) + ))) + +(defn analyse-record [analyse exo-type ?elems] + (|do [[rec-members rec-type] (&&record/order-record ?elems)] + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (analyse-tuple analyse (&/$Right exo-type) rec-members) + (|do [[[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left rec-type) rec-members)) + _ (&type/check exo-type tuple-type)] + (return (&/|list (&&/|meta exo-type tuple-cursor + tuple-analysis)))))) + + _ + (analyse-tuple analyse (&/$Right exo-type) rec-members) + ))) + +(defn ^:private analyse-global [analyse exo-type module name] + (|do [[[r-module r-name] [endo-type ?meta ?value]] (&&module/find-def module name) + ;; This is a small shortcut to optimize analysis of typing code. + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta endo-type _cursor + (&&/$var (&/$Global (&/T [r-module r-name])))))))) + +(defn ^:private analyse-local [analyse exo-type name] + (fn [state] + (|let [stack (&/get$ &/$scopes state) + no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) + (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) + [inner outer] (&/|split-with no-binding? stack)] + (|case outer + (&/$Nil) + (&/run-state (|do [module-name &/get-module-name] + (analyse-global analyse exo-type module-name name)) + state) + + (&/$Cons ?genv (&/$Nil)) + (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] + (|case global + [(&/$Global ?module* name*) _] + (&/run-state (analyse-global analyse exo-type ?module* name*) + state) + + _ + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")) + (fail* (str "[Analyser Error] Unknown global definition: " name))) + + (&/$Cons bottom-outer _) + (|let [scopes (&/|map #(&/get$ &/$name %) (&/|reverse inner)) + [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] + (|let [[register new-inner] register+new-inner + [register* frame*] (&&lambda/close-over in-scope name register frame)] + (&/T [register* (&/$Cons frame* new-inner)]))) + (&/T [(or (->> bottom-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) + (->> bottom-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) + &/$Nil]) + (&/|reverse inner) scopes)] + ((|do [_ (&type/check exo-type (&&/expr-type* =local))] + (return (&/|list =local))) + (&/set$ &/$scopes (&/|++ inner* outer) state))) + )))) + +(defn analyse-symbol [analyse exo-type ident] + (|do [:let [[?module ?name] ident]] + (if (= "" ?module) + (analyse-local analyse exo-type ?name) + (analyse-global analyse exo-type ?module ?name)) + )) + +(defn ^:private analyse-apply* [analyse exo-type fun-type ?args] + (|case ?args + (&/$Nil) + (|do [_ (&type/check exo-type fun-type)] + (return (&/T [fun-type &/$Nil]))) + + (&/$Cons ?arg ?args*) + (|do [?fun-type* (&type/actual-type fun-type)] + (&/with-attempt + (|case ?fun-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [type* (&type/apply-type ?fun-type* $var) + [=output-t =args] (analyse-apply* analyse exo-type type* ?args) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (|case $var + (&/$VarT ?id) + (|do [? (&type/bound? ?id) + type** (if ? + (&type/clean $var =output-t) + (|do [_ (&type/set-var ?id (next-bound-type =output-t)) + cleaned-output* (&type/clean $var =output-t) + :let [cleaned-output (&/$UnivQ &/$Nil cleaned-output*)]] + (return cleaned-output))) + _ (&type/clean $var exo-type)] + (return (&/T [type** ==args]))) + )))) + + (&/$ExQ _) + (|do [$var &type/existential + type* (&type/apply-type ?fun-type* $var)] + (analyse-apply* analyse exo-type type* ?args)) + + (&/$LambdaT ?input-t ?output-t) + (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) + =arg (&/with-attempt + (&&/analyse-1 analyse ?input-t ?arg) + (fn [err] + (&/fail-with-loc (str err "\n" "[Analyser Error] Function expected: " (&type/show-type ?input-t)))))] + (return (&/T [=output-t (&/$Cons =arg =args)]))) + + _ + (&/fail-with-loc (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*)))) + (fn [err] + (&/fail-with-loc (str err "\n" "[Analyser Error] Can't apply function " (&type/show-type fun-type) " to args: " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) + )) + +(defn ^:private do-analyse-apply [analyse exo-type =fn ?args] + (|do [:let [[[=fn-type =fn-cursor] =fn-form] =fn] + [=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] + (return (&/|list (&&/|meta =output-t =fn-cursor + (&&/$apply =fn =args) + ))))) + +(defn analyse-apply [analyse cursor exo-type =fn ?args] + (|do [loader &/loader + :let [[[=fn-type =fn-cursor] =fn-form] =fn]] + (|case =fn-form + (&&/$var (&/$Global ?module ?name)) + (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)] + (|case (&&meta/meta-get &&meta/macro?-tag ?meta) + (&/$Some _) + (|do [macro-expansion (fn [state] + (|case (-> ?value (.apply ?args) (.apply state)) + (&/$Right state* output) + (&/$Right (&/T [state* output])) + + (&/$Left error) + ((&/fail-with-loc error) state))) + module-name &/get-module-name + ;; :let [[r-prefix r-name] real-name + ;; _ (when (or (= "actor:" r-name) + ;; ;; (= "|Codec@Json|" r-name) + ;; ;; (= "|Codec@Json//encode|" r-name) + ;; ;; (= "|Codec@Json//decode|" r-name) + ;; ;; (= "derived:" r-name) + ;; ) + ;; (->> (&/|map &/show-ast macro-expansion) + ;; (&/|interpose "\n") + ;; (&/fold str "") + ;; (prn (&/ident->text real-name) module-name))) + ;; ] + ] + (&/flat-map% (partial analyse exo-type) macro-expansion)) + + _ + (do-analyse-apply analyse exo-type =fn ?args))) + + _ + (do-analyse-apply analyse exo-type =fn ?args)) + )) + +(defn analyse-case [analyse exo-type ?value ?branches] + (|do [:let [num-branches (&/|length ?branches)] + _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case\" expression.") + _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case\" expression.") + =value (&&/analyse-1+ analyse ?value) + :let [var?? (|case =value + [_ (&&/$var =var-kind)] + (&/$Some =value) + + _ + &/$None)] + =match (&&case/analyse-branches analyse exo-type var?? (&&/expr-type* =value) (&/|as-pairs ?branches)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$case =value =match) + ))))) + +(defn ^:private unravel-inf-appt [type] + (|case type + (&/$AppT =input+ (&/$VarT _inf-var)) + (&/$Cons _inf-var (unravel-inf-appt =input+)) + + _ + (&/|list))) + +(defn ^:private clean-func-inference [$input $output =input =func] + (|case =input + (&/$VarT iid) + (|do [:let [=input* (next-bound-type =func)] + _ (&type/set-var iid =input*) + =func* (&type/clean $input =func) + =func** (&type/clean $output =func*)] + (return (&/$UnivQ &/$Nil =func**))) + + (&/$AppT =input+ (&/$VarT _inf-var)) + (&/fold% (fn [_func _inf-var] + (|do [:let [$inf-var (&/$VarT _inf-var)] + =inf-var (&type/resolve-type $inf-var) + _func* (clean-func-inference $inf-var $output =inf-var _func) + _ (&type/delete-var _inf-var)] + (return _func*))) + =func + (unravel-inf-appt =input)) + + (&/$ProdT _ _) + (&/fold% (fn [_func _inf-var] + (|do [:let [$inf-var (&/$VarT _inf-var)] + =inf-var (&type/resolve-type $inf-var) + _func* (clean-func-inference $inf-var $output =inf-var _func) + _ (&type/delete-var _inf-var)] + (return _func*))) + =func + (&/|reverse (&type/flatten-prod =input))) + + _ + (|do [=func* (&type/clean $input =func) + =func** (&type/clean $output =func*)] + (return =func**)))) + +(defn analyse-lambda* [analyse exo-type ?self ?arg ?body] + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (|do [exo-type* (&type/deref id)] + (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + ;; Inference + (&type/with-var + (fn [$input] + (&type/with-var + (fn [$output] + (|do [[[lambda-type lambda-cursor] lambda-analysis] (analyse-lambda* analyse (&/$LambdaT $input $output) ?self ?arg ?body) + =input (&type/resolve-type $input) + =output (&type/resolve-type $output) + inferred-type (clean-func-inference $input $output =input (embed-inferred-input =input =output)) + _ (&type/check exo-type inferred-type)] + (return (&&/|meta inferred-type lambda-cursor + lambda-analysis))) + )))))) + + _ + (&/with-attempt + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (|do [$var &type/existential + :let [(&/$ExT $var-id) $var] + exo-type** (&type/apply-type exo-type* $var)] + (&/with-scope-type-var $var-id + (analyse-lambda* analyse exo-type** ?self ?arg ?body))) + + (&/$ExQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + =expr (analyse-lambda* analyse exo-type** ?self ?arg ?body)] + (&&/clean-analysis $var =expr)))) + + (&/$LambdaT ?arg-t ?return-t) + (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* + ?arg ?arg-t + (&&/analyse-1 analyse ?return-t ?body)) + _cursor &/cursor + register-offset &&env/next-local-idx] + (return (&&/|meta exo-type* _cursor + (&&/$lambda register-offset =scope =captured =body)))) + + _ + (fail ""))) + (fn [err] + (&/fail-with-loc (str err "\n" "[Analyser Error] Functions require function types: " (&type/show-type exo-type))))) + )) + +(defn analyse-lambda** [analyse exo-type ?self ?arg ?body] + (|case exo-type + (&/$UnivQ _) + (|do [$var &type/existential + :let [(&/$ExT $var-id) $var] + exo-type* (&type/apply-type exo-type $var) + [_ _expr] (&/with-scope-type-var $var-id + (analyse-lambda** analyse exo-type* ?self ?arg ?body)) + _cursor &/cursor] + (return (&&/|meta exo-type _cursor _expr))) + + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (|do [exo-type* (&type/actual-type exo-type)] + (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + ;; Inference + (analyse-lambda* analyse exo-type ?self ?arg ?body))) + + _ + (|do [exo-type* (&type/actual-type exo-type)] + (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + )) + +(defn analyse-lambda [analyse exo-type ?self ?arg ?body] + (|do [output (&/with-no-catches + (analyse-lambda** analyse exo-type ?self ?arg ?body))] + (return (&/|list output)))) + +(defn analyse-def [analyse optimize eval! compile-def ?name ?value ?meta] + (|do [_ &/ensure-statement + module-name &/get-module-name + ? (&&module/defined? module-name ?name)] + (if ? + (&/fail-with-loc (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) + (|do [=value (&/without-repl-closure + (&/with-scope ?name + (&&/analyse-1+ analyse ?value))) + =meta (&&/analyse-1 analyse &type/Anns ?meta) + ==meta (eval! (optimize =meta)) + _ (&&module/test-type module-name ?name ==meta (&&/expr-type* =value)) + _ (&&module/test-macro module-name ?name ==meta (&&/expr-type* =value)) + _ (compile-def ?name (optimize =value) ==meta)] + (return &/$Nil)) + ))) + +(defn ^:private merge-hosts + "(-> Host Host Host)" + [new old] + (|let [merged-module-states (&/fold (fn [total m-state] + (|let [[_name _state] m-state] + (|case _state + (&/$Cached) + (&/|put _name _state total) + + (&/$Compiled) + (&/|put _name _state total) + + _ + total))) + (&/get$ &/$module-states old) + (&/get$ &/$module-states new))] + (->> old + (&/set$ &/$module-states merged-module-states)))) + +(defn ^:private merge-modules + "(-> Text Module Module Module)" + [current-module new old] + (&/fold (fn [total* entry] + (|let [[_name _module] entry] + (if (or (= current-module _name) + (->> _module + (&/get$ &&module/$defs) + &/|length + (= 0))) + ;; Don't modify the entry of the current module, to + ;; avoid overwritting it's data in improper ways. + ;; Since it's assumed the "original" old module + ;; contains all the proper own-module information. + total* + (&/|put _name _module total*)))) + old new)) + +(defn ^:private merge-compilers + "(-> Text Compiler Compiler Compiler)" + [current-module new old] + (->> old + (&/set$ &/$modules (merge-modules current-module + (&/get$ &/$modules new) + (&/get$ &/$modules old))) + (&/set$ &/$seed (max (&/get$ &/$seed new) + (&/get$ &/$seed old))) + (&/set$ &/$host (merge-hosts (&/get$ &/$host new) + (&/get$ &/$host old))))) + +(def ^:private get-compiler + (fn [compiler] + (return* compiler compiler))) + +(defn ^:private set-compiler [compiler*] + (fn [_] + (return* compiler* compiler*))) + +(defn analyse-module [analyse optimize eval! compile-module ?meta] + (|do [_ &/ensure-statement + =anns (&&/analyse-1 analyse &type/Anns ?meta) + ==anns (eval! (optimize =anns)) + module-name &/get-module-name + _ (&&module/set-anns ==anns module-name) + _imports (&&module/fetch-imports ==anns) + current-module &/get-module-name + ;; =asyncs (&/map% (fn [_import] + ;; (|let [[path alias] _import] + ;; (&/without-repl + ;; (&/save-module + ;; (|do [_ (if (= current-module path) + ;; (&/fail-with-loc (str "[Analyser Error] Module can't import itself: " path)) + ;; (return nil)) + ;; already-compiled? (&&module/exists? path) + ;; active? (&/active-module? path) + ;; _ (&/assert! (not active?) + ;; (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " current-module)) + ;; _ (&&module/add-import path) + ;; ?async (if (not already-compiled?) + ;; (compile-module path) + ;; (|do [_compiler get-compiler] + ;; (return (doto (promise) + ;; (deliver (&/$Right _compiler)))))) + ;; _ (if (= "" alias) + ;; (return nil) + ;; (&&module/alias current-module alias path))] + ;; (return ?async)))))) + ;; _imports) + ;; _compiler get-compiler + ;; ;; Some type-vars in the typing environment stay in + ;; ;; the environment forever, making type-checking slower. + ;; ;; The merging process for compilers more-or-less "fixes" the + ;; ;; problem by resetting the typing enviroment, but ideally + ;; ;; those type-vars shouldn't survive in the first place. + ;; ;; TODO: MUST FIX + ;; _ (&/fold% (fn [compiler _async] + ;; (|case @_async + ;; (&/$Right _new-compiler) + ;; (set-compiler (merge-compilers current-module _new-compiler compiler)) + + ;; (&/$Left ?error) + ;; (fail ?error))) + ;; _compiler + ;; =asyncs) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + _ (&/map% (fn [_import] + (|let [[path alias] _import] + (&/without-repl + (&/save-module + (|do [_ (if (= current-module path) + (&/fail-with-loc (str "[Analyser Error] Module can't import itself: " path)) + (return nil)) + already-compiled? (&&module/exists? path) + active? (&/active-module? path) + _ (&/assert! (not active?) + (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " current-module)) + _ (&&module/add-import path) + _ (if (not already-compiled?) + (compile-module path) + (return nil)) + _ (if (= "" alias) + (return nil) + (&&module/alias current-module alias path))] + (return nil)))))) + _imports)] + (return &/$Nil))) + +(defn ^:private coerce [new-type analysis] + "(-> Type Analysis Analysis)" + (|let [[[_type _cursor] _analysis] analysis] + (&&/|meta new-type _cursor + _analysis))) + +(defn analyse-ann [analyse eval! exo-type ?type ?value] + (|do [=type (&&/analyse-1 analyse &type/Type ?type) + ==type (eval! =type) + _ (&type/check exo-type ==type) + =value (&/with-expected-type ==type + (&&/analyse-1 analyse ==type ?value)) + _cursor &/cursor] + (return (&/|list (&&/|meta ==type _cursor + (&&/$ann =value =type) + ))))) + +(defn analyse-coerce [analyse eval! exo-type ?type ?value] + (|do [=type (&&/analyse-1 analyse &type/Type ?type) + ==type (eval! =type) + _ (&type/check exo-type ==type) + =value (&&/analyse-1+ analyse ?value)] + (return (&/|list (coerce ==type =value))))) + +(let [input-type (&/$AppT &type/List &type/Text) + output-type (&/$AppT &type/IO &/$UnitT)] + (defn analyse-program [analyse optimize compile-program ?args ?body] + (|do [_ &/ensure-statement + =body (&/with-scope "" + (&&env/with-local ?args input-type + (&&/analyse-1 analyse output-type ?body))) + _ (compile-program (optimize =body))] + (return &/$Nil)))) diff --git a/luxc/src/lux/analyser/meta.clj b/luxc/src/lux/analyser/meta.clj new file mode 100644 index 000000000..831386f47 --- /dev/null +++ b/luxc/src/lux/analyser/meta.clj @@ -0,0 +1,46 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.meta + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return return* fail fail* |case]]))) + +;; [Utils] +(defn ^:private ident= [x y] + (|let [[px nx] x + [py ny] y] + (and (= px py) + (= nx ny)))) + +(def ^:private tag-prefix "lux") + +;; [Values] +(defn meta-get [ident dict] + "(-> Ident Anns (Maybe Ann-Value))" + (|case dict + (&/$Cons [k v] dict*) + (if (ident= k ident) + (&/$Some v) + (meta-get ident dict*)) + + (&/$Nil) + &/$None + + _ + (assert false (prn-str (&/adt->text ident) + (&/adt->text dict))))) + +(do-template [ ] + (def (&/T [tag-prefix ])) + + type?-tag "type?" + alias-tag "alias" + macro?-tag "macro?" + export?-tag "export?" + tags-tag "tags" + imports-tag "imports" + ) diff --git a/luxc/src/lux/analyser/module.clj b/luxc/src/lux/analyser/module.clj new file mode 100644 index 000000000..62948bf0d --- /dev/null +++ b/luxc/src/lux/analyser/module.clj @@ -0,0 +1,403 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.module + (:refer-clojure :exclude [alias]) + (:require (clojure [string :as string] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [deftuple |let |do return return* |case]] + [type :as &type] + [host :as &host]) + [lux.host.generics :as &host-generics] + (lux.analyser [meta :as &meta]))) + +;; [Utils] +(deftuple + ["module-hash" + "module-aliases" + "defs" + "imports" + "tags" + "types" + "module-anns"]) + +(defn ^:private new-module [hash] + (&/T [;; lux;module-hash + hash + ;; "lux;module-aliases" + (&/|table) + ;; "lux;defs" + (&/|table) + ;; "lux;imports" + &/$Nil + ;; "lux;tags" + (&/|table) + ;; "lux;types" + (&/|table) + ;; module-anns + (&/|list)] + )) + +;; [Exports] +(defn add-import + "(-> Text (Lux Null))" + [module] + (|do [current-module &/get-module-name] + (fn [state] + (if (&/|member? module (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $imports))) + ((&/fail-with-loc (str "[Analyser Error] Can't import module " (pr-str module) " twice @ " current-module)) + state) + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/update$ $imports (partial &/$Cons module) m)) + ms)) + state) + nil))))) + +(defn set-imports + "(-> (List Text) (Lux Null))" + [imports] + (|do [current-module &/get-module-name] + (fn [state] + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/set$ $imports imports m)) + ms)) + state) + nil)))) + +(defn define [module name def-type def-meta def-value] + (fn [state] + (when (and (= "Macro" name) (= "lux" module)) + (&type/set-macro-type! def-value)) + (|case (&/get$ &/$scopes state) + (&/$Cons ?env (&/$Nil)) + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/T [def-type def-meta def-value]) %) + m)) + ms)))) + nil) + + _ + ((&/fail-with-loc (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name)) + state)))) + +(defn def-type + "(-> Text Text (Lux Type))" + [module name] + (fn [state] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|let [[?type ?meta ?value] $def] + (return* state ?type)) + ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (str module ";" name))) + state)) + ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module)) + state)))) + +(defn type-def + "(-> Text Text (Lux [Bool Type]))" + [module name] + (fn [state] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|let [[?type ?meta ?value] $def] + (|case (&meta/meta-get &meta/type?-tag ?meta) + (&/$Some _) + (return* state (&/T [(|case (&meta/meta-get &meta/export?-tag ?meta) + (&/$Some _) + true + + _ + false) + ?value])) + + _ + ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])))) + state))) + ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T [module name])))) + state)) + ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module)) + state)))) + +(defn exists? + "(-> Text (Lux Bool))" + [name] + (fn [state] + (return* state + (->> state (&/get$ &/$modules) (&/|contains? name))))) + +(defn dealias [name] + (|do [current-module &/get-module-name] + (fn [state] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] + (return* state real-name) + ((&/fail-with-loc (str "[Analyser Error] Unknown alias: " name)) + state))))) + +(defn alias [module alias reference] + (fn [state] + (let [_module_ (->> state (&/get$ &/$modules) (&/|get module))] + (if (&/|member? module (->> _module_ (&/get$ $imports))) + ((&/fail-with-loc (str "[Analyser Error] Can't create alias that is the same as a module nameL " (pr-str alias) " for " reference)) + state) + (if-let [real-name (->> _module_ (&/get$ $module-aliases) (&/|get alias))] + ((&/fail-with-loc (str "[Analyser Error] Can't re-use alias \"" alias "\" @ " module)) + state) + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module + #(&/update$ $module-aliases + (fn [aliases] + (&/|put alias reference aliases)) + %) + ms)))) + nil)))) + )) + +(defn ^:private imports? [state imported-module-name source-module-name] + (->> state + (&/get$ &/$modules) + (&/|get source-module-name) + (&/get$ $imports) + (&/|any? (partial = imported-module-name)))) + +(defn get-anns [module-name] + (fn [state] + (if-let [module (->> state + (&/get$ &/$modules) + (&/|get module-name))] + (return* state (&/get$ $module-anns module)) + ((&/fail-with-loc (str "[Analyser Error] Module does not exist: " module-name)) + state)))) + +(defn set-anns [anns module-name] + (fn [state] + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module-name + #(&/set$ $module-anns anns %) + ms)))) + nil))) + +(defn find-def [module name] + (|do [current-module &/get-module-name] + (fn [state] + (if (or (= "lux" module) + (= current-module module) + (imports? state module current-module)) + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|let [[?type ?meta ?value] $def] + (if (.equals ^Object current-module module) + (|case (&meta/meta-get &meta/alias-tag ?meta) + (&/$Some (&/$IdentM [?r-module ?r-name])) + ((find-def ?r-module ?r-name) + state) + + _ + (return* state (&/T [(&/T [module name]) $def]))) + (|case (&meta/meta-get &meta/export?-tag ?meta) + (&/$Some (&/$BoolM true)) + (return* state (&/T [(&/T [module name]) $def])) + + _ + ((&/fail-with-loc (str "[Analyser Error @ find-def] Can't use unexported definition: " (str module &/+name-separator+ name))) + state)))) + ((&/fail-with-loc (str "[Analyser Error @ find-def] Definition does not exist: " (str module &/+name-separator+ name))) + state)) + ((&/fail-with-loc (str "[Analyser Error @ find-def] Module doesn't exist: " module)) + state)) + ((&/fail-with-loc (str "[Analyser Error @ find-def] Unknown module: " module)) + state)) + ))) + +(defn ensure-type-def + "(-> DefData (Lux Type))" + [def-data] + (|let [[?type ?meta ?value] def-data] + (|case (&meta/meta-get &meta/type?-tag ?meta) + (&/$Some _) + (return ?type) + + _ + (&/fail-with-loc (str "[Analyser Error] Not a type definition: " (&/adt->text def-data)))))) + +(defn defined? [module name] + (&/try-all% (&/|list (|do [_ (find-def module name)] + (return true)) + (return false)))) + +(defn create-module + "(-> Text Hash-Code (Lux Null))" + [name hash] + (fn [state] + (return* (->> state + (&/update$ &/$modules #(&/|put name (new-module hash) %)) + (&/set$ &/$scopes (&/|list (&/env name &/$Nil)))) + nil))) + +(do-template [ ] + (defn + + [module] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (return* state (&/get$ =module)) + ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) + state)) + )) + + tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" + types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + module-hash $module-hash "(-> Text (Lux Int))" + ) + +(def imports + (|do [module &/get-module-name + _imports (fn [state] + (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports))))] + (&/map% (fn [_module] + (|do [_hash (module-hash _module)] + (return (&/T [_module _hash])))) + _imports))) + +(defn ensure-undeclared-tags [module tags] + (|do [tags-table (tags-by-module module) + _ (&/map% (fn [tag] + (if (&/|get tag tags-table) + (&/fail-with-loc (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T [module tag])))) + (return nil))) + tags)] + (return nil))) + +(defn ensure-undeclared-type [module name] + (|do [types-table (types-by-module module) + _ (&/assert! (nil? (&/|get name types-table)) + (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T [module name]))))] + (return nil))) + +(defn declare-tags + "(-> Text (List Text) Bool Type (Lux Null))" + [module tag-names was-exported? type] + (|do [_ (ensure-undeclared-tags module tag-names) + type-name (&type/type-name type) + :let [[_module _name] type-name] + _ (&/assert! (= module _module) + (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name))) + _ (ensure-undeclared-type _module _name)] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T [module tag-name])) tag-names)] + (return* (&/update$ &/$modules + (fn [=modules] + (&/|update module + #(->> % + (&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T [idx tags was-exported? type]) table))) + (&/get$ $tags %) + (&/enumerate tag-names))) + (&/update$ $types (partial &/|put _name (&/T [tags was-exported? type])))) + =modules)) + state) + nil)) + ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) + state))))) + +(defn ensure-can-see-tag + "(-> Text Text (Lux Unit))" + [module tag-name] + (|do [current-module &/get-module-name] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))] + (|let [[?idx ?tags ?exported ?type] idx+tags+exported+type] + (if (or ?exported + (= module current-module)) + (return* state &/unit-tag) + ((&/fail-with-loc (str "[Analyser Error] Can't access tag #" (&/ident->text (&/T [module tag-name])) " from module " current-module)) + state))) + ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name])))) + state)) + ((&/fail-with-loc (str "[Module Error] Unknown module: " module)) + state))))) + +(do-template [ ] + (defn + + [module tag-name] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))] + (|let [[?idx ?tags ?exported ?type] idx+tags+exported+type] + (return* state )) + ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name])))) + state)) + ((&/fail-with-loc (str "[Module Error] Unknown module: " module)) + state)))) + + tag-index ?idx "(-> Text Text (Lux Int))" + tag-group ?tags "(-> Text Text (Lux (List Ident)))" + tag-type ?type "(-> Text Text (Lux Type))" + ) + +(def defs + (|do [module &/get-module-name] + (fn [state] + (return* state + (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) + (&/|map (fn [kv] + (|let [[k _def-data] kv + [_ ?def-meta _] _def-data] + (|case (&meta/meta-get &meta/alias-tag ?def-meta) + (&/$Some (&/$IdentM [?r-module ?r-name])) + (&/T [k (str ?r-module ";" ?r-name) _def-data]) + + _ + (&/T [k "" _def-data]) + ))))))))) + +(do-template [ ] + (defn [module name meta type] + (|case (&meta/meta-get meta) + (&/$Some (&/$BoolM true)) + (&/try-all% (&/|list (&type/check type) + (&/fail-with-loc (str "[Analyser Error] Can't tag as lux;" "? if it's not a " ": " (str module ";" name))))) + + _ + (return nil))) + + test-type &type/Type &meta/type?-tag "type" + test-macro &type/Macro &meta/macro?-tag "macro" + ) + +(defn fetch-imports [meta] + (|case (&meta/meta-get &meta/imports-tag meta) + (&/$Some (&/$ListM _parts)) + (&/map% (fn [_part] + (|case _part + (&/$ListM (&/$Cons [(&/$TextM _module) + (&/$Cons [(&/$TextM _alias) + (&/$Nil)])])) + (return (&/T [_module _alias])) + + _ + (&/fail-with-loc "[Analyser Error] Wrong import syntax."))) + _parts) + + _ + (&/fail-with-loc "[Analyser Error] No import meta-data."))) diff --git a/luxc/src/lux/analyser/parser.clj b/luxc/src/lux/analyser/parser.clj new file mode 100644 index 000000000..e60f28a02 --- /dev/null +++ b/luxc/src/lux/analyser/parser.clj @@ -0,0 +1,469 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.parser + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [reader :as &reader] + [lexer :as &lexer] + [parser :as &parser]))) + +(declare parse-gclass) + +;; [Parsers] +(def ^:private _space_ (&reader/read-text " ")) + +(defn ^:private repeat% [action] + (fn [state] + (|case (action state) + (&/$Left ^String error) + (&/$Right (&/T [state &/$Nil])) + + (&/$Right state* head) + ((|do [tail (repeat% action)] + (return (&/$Cons head tail))) + state*)))) + +(defn ^:private spaced [action] + (fn [state] + (|case (action state) + (&/$Left ^String error) + (&/$Right (&/T [state &/$Nil])) + + (&/$Right state* head) + ((&/try-all% (&/|list (|do [_ _space_ + tail (spaced action)] + (return (&/$Cons head tail))) + (return (&/|list head)))) + state*)))) + +(def ^:private parse-name + (|do [[_ _ =name] (&reader/read-regex #"^([a-zA-Z0-9_\.]+)")] + (return =name))) + +(def ^:private parse-ident + (|do [[_ _ =name] (&reader/read-regex &lexer/+ident-re+)] + (return =name))) + +(defn ^:private with-parens [body] + (|do [_ (&reader/read-text "(") + output body + _ (&reader/read-text ")")] + (return output))) + +(defn ^:private with-brackets [body] + (|do [_ (&reader/read-text "[") + output body + _ (&reader/read-text "]")] + (return output))) + +(defn ^:private with-braces [body] + (|do [_ (&reader/read-text "{") + output body + _ (&reader/read-text "}")] + (return output))) + +(def ^:private parse-type-param + (with-parens + (|do [=name parse-name + _ _space_ + =bounds (spaced parse-gclass)] + (return (&/T [=name =bounds]))))) + +(def ^:private parse-gclass-decl + (with-parens + (|do [=class-name parse-name + _ _space_ + =params (spaced parse-type-param)] + (return (&/T [=class-name =params]))))) + +(def ^:private parse-bound-kind + (&/try-all% (&/|list (|do [_ (&reader/read-text "<")] + (return &/$UpperBound)) + + (|do [_ (&reader/read-text ">")] + (return &/$LowerBound)) + ))) + +(def parse-gclass + (&/try-all% (&/|list (|do [=bound-kind parse-bound-kind + =bound parse-gclass] + (return (&/$GenericWildcard (&/$Some (&/T [=bound-kind =bound]))))) + + (|do [_ (&reader/read-text "?")] + (return (&/$GenericWildcard &/$None))) + + (|do [var-name parse-name] + (return (&/$GenericTypeVar var-name))) + + (with-parens + (|do [class-name parse-name + _ _space_ + =params (spaced parse-gclass)] + (return (&/$GenericClass class-name =params)))) + + (with-parens + (|do [_ (&reader/read-text "Array") + _ _space_ + =param parse-gclass] + (return (&/$GenericArray =param)))) + ))) + +(def ^:private parse-gclass-super + (with-parens + (|do [class-name parse-name + _ _space_ + =params (spaced parse-gclass)] + (return (&/T [class-name =params]))))) + +(def ^:private parse-ctor-arg + (with-brackets + (|do [=class parse-gclass + (&/$Cons =term (&/$Nil)) &parser/parse] + (return (&/T [=class =term]))))) + +(def ^:private parse-ann-param + (|do [param-name parse-name + _ (&reader/read-text "=") + param-value (&/try-all% (&/|list (|do [[_ (&lexer/$Bool param-value*)] &lexer/lex-bool] + (return (boolean param-value*))) + + (|do [[_ (&lexer/$Int param-value*)] &lexer/lex-int] + (return (int param-value*))) + + (|do [_ (&reader/read-text "l") + [_ (&lexer/$Int param-value*)] &lexer/lex-int] + (return (long param-value*))) + + (|do [[_ (&lexer/$Real param-value*)] &lexer/lex-real] + (return (float param-value*))) + + (|do [_ (&reader/read-text "d") + [_ (&lexer/$Real param-value*)] &lexer/lex-real] + (return (double param-value*))) + + (|do [[_ (&lexer/$Char param-value*)] &lexer/lex-char] + (return (char param-value*))) + + (|do [[_ (&lexer/$Text param-value*)] &lexer/lex-text] + (return param-value*)) + ))] + (return (&/T [param-name param-value])))) + +(def ^:private parse-ann + (with-parens + (|do [ann-name parse-name + _ _space_ + =ann-params (with-braces + (spaced parse-ann-param))] + (return {:name ann-name + :params =ann-params})))) + +(def ^:private parse-arg-decl + (with-parens + (|do [=arg-name parse-ident + _ (&reader/read-text " ") + =gclass parse-gclass] + (return (&/T [=arg-name =gclass]))))) + +(def ^:private parse-gvars + (|do [=head parse-name + [_ _ ?] (&reader/read-text? " ")] + (if ? + (|do [=tail parse-gvars] + (return (&/$Cons =head =tail))) + (return (&/|list =head))))) + +(def ^:private parse-method-decl + (with-parens + (|do [=method-name parse-name + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + parse-gvars) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-gclass)) + _ _space_ + =output parse-gclass] + (return (&/T [=method-name =anns =gvars =exceptions =inputs =output]))))) + +(def ^:private parse-privacy-modifier + (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] + (return &/$DefaultPM)) + + (|do [_ (&reader/read-text "public")] + (return &/$PublicPM)) + + (|do [_ (&reader/read-text "protected")] + (return &/$ProtectedPM)) + + (|do [_ (&reader/read-text "private")] + (return &/$PrivatePM)) + ))) + +(def ^:private parse-state-modifier + (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] + (return &/$DefaultSM)) + + (|do [_ (&reader/read-text "volatile")] + (return &/$VolatileSM)) + + (|do [_ (&reader/read-text "final")] + (return &/$FinalSM)) + ))) + +(def ^:private parse-inheritance-modifier + (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] + (return &/$DefaultIM)) + + (|do [_ (&reader/read-text "abstract")] + (return &/$AbstractIM)) + + (|do [_ (&reader/read-text "final")] + (return &/$FinalIM)) + ))) + +(def ^:private parse-method-init-def + (|do [_ (&reader/read-text "init") + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + [_ (&lexer/$Bool =strict*)] &lexer/lex-bool + :let [=strict (Boolean/parseBoolean =strict*)] + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =ctor-args (with-brackets + (spaced parse-ctor-arg)) + _ _space_ + (&/$Cons =body (&/$Nil)) &parser/parse] + (return (&/$ConstructorMethodSyntax (&/T [=privacy-modifier =strict =anns =gvars =exceptions =inputs =ctor-args =body]))))) + +(def ^:private parse-method-virtual-def + (|do [_ (&reader/read-text "virtual") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + [_ (&lexer/$Bool =final?*)] &lexer/lex-bool + :let [=final? (Boolean/parseBoolean =final?*)] + _ _space_ + [_ (&lexer/$Bool =strict*)] &lexer/lex-bool + :let [=strict (Boolean/parseBoolean =strict*)] + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass + _ _space_ + (&/$Cons =body (&/$Nil)) &parser/parse] + (return (&/$VirtualMethodSyntax (&/T [=name =privacy-modifier =final? =strict =anns =gvars =exceptions =inputs =output =body]))))) + +(def ^:private parse-method-override-def + (|do [_ (&reader/read-text "override") + _ _space_ + =class-decl parse-gclass-decl + _ _space_ + =name parse-name + _ _space_ + [_ (&lexer/$Bool =strict*)] &lexer/lex-bool + :let [=strict (Boolean/parseBoolean =strict*)] + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass + _ _space_ + (&/$Cons =body (&/$Nil)) &parser/parse] + (return (&/$OverridenMethodSyntax (&/T [=class-decl =name =strict =anns =gvars =exceptions =inputs =output =body]))))) + +(def ^:private parse-method-static-def + (|do [_ (&reader/read-text "static") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + [_ (&lexer/$Bool =strict*)] &lexer/lex-bool + :let [=strict (Boolean/parseBoolean =strict*)] + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass + _ _space_ + (&/$Cons =body (&/$Nil)) &parser/parse] + (return (&/$StaticMethodSyntax (&/T [=name =privacy-modifier =strict =anns =gvars =exceptions =inputs =output =body]))))) + +(def ^:private parse-method-abstract-def + (|do [_ (&reader/read-text "abstract") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass] + (return (&/$AbstractMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output]))))) + +(def ^:private parse-method-native-def + (|do [_ (&reader/read-text "native") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass] + (return (&/$NativeMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output]))))) + +(def ^:private parse-method-def + (with-parens + (&/try-all% (&/|list parse-method-init-def + parse-method-virtual-def + parse-method-override-def + parse-method-static-def + parse-method-abstract-def + parse-method-native-def + )))) + +(def ^:private parse-field + (with-parens + (&/try-all% (&/|list (|do [_ (&reader/read-text "constant") + _ _space_ + =name parse-name + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =type parse-gclass + _ _space_ + (&/$Cons =value (&/$Nil)) &parser/parse] + (return (&/$ConstantFieldSyntax =name =anns =type =value))) + + (|do [_ (&reader/read-text "variable") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + =state-modifier parse-state-modifier + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =type parse-gclass] + (return (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type))) + )))) + +(def parse-interface-def + (|do [=gclass-decl parse-gclass-decl + =supers (with-brackets + (spaced parse-gclass-super)) + =anns (with-brackets + (spaced parse-ann)) + =methods (spaced parse-method-decl)] + (return (&/T [=gclass-decl =supers =anns =methods])))) + +(def parse-class-def + (|do [=gclass-decl parse-gclass-decl + _ _space_ + =super-class parse-gclass-super + _ _space_ + =interfaces (with-brackets + (spaced parse-gclass-super)) + _ _space_ + =inheritance-modifier parse-inheritance-modifier + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =fields (with-brackets + (spaced parse-field)) + _ _space_ + =methods (with-brackets + (spaced parse-method-def))] + (return (&/T [=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods])))) + +(def parse-anon-class-def + (|do [=super-class parse-gclass-super + _ _space_ + =interfaces (with-brackets + (spaced parse-gclass-super)) + _ _space_ + =ctor-args (with-brackets + (spaced parse-ctor-arg)) + _ _space_ + =methods (with-brackets + (spaced parse-method-def))] + (return (&/T [=super-class =interfaces =ctor-args =methods])))) diff --git a/luxc/src/lux/analyser/record.clj b/luxc/src/lux/analyser/record.clj new file mode 100644 index 000000000..81332b34c --- /dev/null +++ b/luxc/src/lux/analyser/record.clj @@ -0,0 +1,47 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.record + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return fail |case]] + [type :as &type]) + (lux.analyser [base :as &&] + [module :as &&module]))) + +;; [Exports] +(defn order-record [pairs] + "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" + (|do [[tag-group tag-type] (|case pairs + (&/$Nil) + (return (&/T [&/$Nil &/$UnitT])) + + (&/$Cons [[_ (&/$TagS tag1)] _] _) + (|do [[module name] (&&/resolved-ident tag1) + tags (&&module/tag-group module name) + type (&&module/tag-type module name)] + (return (&/T [tags type]))) + + _ + (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) + =pairs (&/map% (fn [kv] + (|case kv + [[_ (&/$TagS k)] v] + (|do [=k (&&/resolved-ident k)] + (return (&/T [(&/ident->text =k) v]))) + + _ + (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) + pairs) + _ (let [num-expected (&/|length tag-group) + num-got (&/|length =pairs)] + (&/assert! (= num-expected num-got) + (str "[Analyser Error] Wrong number of record members. Expected " num-expected ", but got " num-got "."))) + =members (&/map% (fn [tag] + (if-let [member (&/|get tag =pairs)] + (return member) + (&/fail-with-loc (str "[Analyser Error] Missing tag: " tag)))) + (&/|map &/ident->text tag-group))] + (return (&/T [=members tag-type])))) diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj new file mode 100644 index 000000000..5697415f8 --- /dev/null +++ b/luxc/src/lux/base.clj @@ -0,0 +1,1449 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.base + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array)) + +;; [Tags] +(def unit-tag (.intern (str (char 0) "unit" (char 0)))) + +(defn T [elems] + (case (count elems) + 0 + unit-tag + + 1 + (first elems) + + ;; else + (to-array elems))) + +(defmacro defvariant [& names] + (assert (> (count names) 1)) + `(do ~@(for [[[name num-params] idx] (map vector names (range (count names))) + :let [last-idx (dec (count names)) + is-last? (if (= idx last-idx) + "" + nil) + def-name (with-meta (symbol (str "$" name)) + {::idx idx + ::is-last? is-last?})]] + (cond (= 0 num-params) + `(def ~def-name + (to-array [(int ~idx) ~is-last? unit-tag])) + + (= 1 num-params) + `(defn ~def-name [arg#] + (to-array [(int ~idx) ~is-last? arg#])) + + :else + (let [g!args (map (fn [_] (gensym "arg")) + (range num-params))] + `(defn ~def-name [~@g!args] + (to-array [(int ~idx) ~is-last? (T [~@g!args])]))) + )))) + +(defmacro deftuple [names] + (assert (vector? names)) + `(do ~@(for [[name idx] (map vector names (range (count names)))] + `(def ~(symbol (str "$" name)) + (int ~idx))))) + +;; List +(defvariant + ("Nil" 0) + ("Cons" 2)) + +;; Maybe +(defvariant + ("None" 0) + ("Some" 1)) + +;; Either +(defvariant + ("Left" 1) + ("Right" 1)) + +;; AST +(defvariant + ("BoolS" 1) + ("NatS" 1) + ("IntS" 1) + ("FracS" 1) + ("RealS" 1) + ("CharS" 1) + ("TextS" 1) + ("SymbolS" 1) + ("TagS" 1) + ("FormS" 1) + ("TupleS" 1) + ("RecordS" 1)) + +;; Type +(defvariant + ("HostT" 2) + ("VoidT" 0) + ("UnitT" 0) + ("SumT" 2) + ("ProdT" 2) + ("LambdaT" 2) + ("BoundT" 1) + ("VarT" 1) + ("ExT" 1) + ("UnivQ" 2) + ("ExQ" 2) + ("AppT" 2) + ("NamedT" 2)) + +;; Vars +(defvariant + ("Local" 1) + ("Global" 1)) + +;; Binding +(deftuple + ["counter" + "mappings"]) + +;; Env +(deftuple + ["name" + "inner-closures" + "locals" + "closure"]) + +;; ModuleState +(defvariant + ("Active" 0) + ("Compiled" 0) + ("Cached" 0)) + +;; Host +(deftuple + ["writer" + "loader" + "classes" + "catching" + "module-states" + "type-env" + "dummy-mappings" + ]) + +;; Compiler +(defvariant + ("Release" 0) + ("Debug" 0) + ("Eval" 0) + ("REPL" 0)) + +(deftuple + ["compiler-name" + "compiler-version" + "compiler-mode"]) + +(deftuple + ["info" + "source" + "cursor" + "modules" + "scopes" + "type-vars" + "expected" + "seed" + "scope-type-vars" + "host"]) + +;; Compiler +(defvariant + ("UpperBound" 0) + ("LowerBound" 0)) + +(defvariant + ("GenericTypeVar" 1) + ("GenericClass" 2) + ("GenericArray" 1) + ("GenericWildcard" 1)) + +;; Privacy Modifiers +(defvariant + ("DefaultPM" 0) + ("PublicPM" 0) + ("PrivatePM" 0) + ("ProtectedPM" 0)) + +;; State Modifiers +(defvariant + ("DefaultSM" 0) + ("VolatileSM" 0) + ("FinalSM" 0)) + +;; Inheritance Modifiers +(defvariant + ("DefaultIM" 0) + ("AbstractIM" 0) + ("FinalIM" 0)) + +;; Fields +(defvariant + ("ConstantFieldSyntax" 4) + ("VariableFieldSyntax" 5)) + +(defvariant + ("ConstantFieldAnalysis" 4) + ("VariableFieldAnalysis" 5)) + +;; Methods +(defvariant + ("ConstructorMethodSyntax" 1) + ("VirtualMethodSyntax" 1) + ("OverridenMethodSyntax" 1) + ("StaticMethodSyntax" 1) + ("AbstractMethodSyntax" 1) + ("NativeMethodSyntax" 1)) + +(defvariant + ("ConstructorMethodAnalysis" 1) + ("VirtualMethodAnalysis" 1) + ("OverridenMethodAnalysis" 1) + ("StaticMethodAnalysis" 1) + ("AbstractMethodAnalysis" 1) + ("NativeMethodAnalysis" 1)) + +;; Meta-data +(defvariant + ("BoolM" 1) + ("NatM" 1) + ("IntM" 1) + ("FracM" 1) + ("RealM" 1) + ("CharM" 1) + ("TextM" 1) + ("IdentM" 1) + ("ListM" 1) + ("DictM" 1)) + +;; [Exports] +(def ^:const name-field "_name") +(def ^:const hash-field "_hash") +(def ^:const value-field "_value") +(def ^:const compiler-field "_compiler") +(def ^:const eval-field "_eval") +(def ^:const module-class-name "_") +(def ^:const +name-separator+ ";") + +(def ^:const ^String compiler-name "Lux/JVM") +(def ^:const ^String compiler-version "0.5.0") + +;; Constructors +(def empty-cursor (T ["" -1 -1])) + +(defn get$ [slot ^objects record] + (aget record slot)) + +(defn set$ [slot value ^objects record] + (doto (aclone ^objects record) + (aset slot value))) + +(defmacro update$ [slot f record] + `(let [record# ~record] + (set$ ~slot (~f (get$ ~slot record#)) + record#))) + +(defn fail* [message] + ($Left message)) + +(defn return* [state value] + ($Right (T [state value]))) + +(defn transform-pattern [pattern] + (cond (vector? pattern) (case (count pattern) + 0 + unit-tag + + 1 + (transform-pattern (first pattern)) + + ;; else + (mapv transform-pattern pattern)) + (seq? pattern) [(if-let [tag-var (ns-resolve *ns* (first pattern))] + (-> tag-var + meta + ::idx) + (assert false (str "Unknown var: " (first pattern)))) + '_ + (transform-pattern (vec (rest pattern)))] + :else pattern + )) + +(defmacro |case [value & branches] + (assert (= 0 (mod (count branches) 2))) + (let [value* (if (vector? value) + [`(T [~@value])] + [value])] + `(matchv ::M/objects ~value* + ~@(mapcat (fn [[pattern body]] + (list [(transform-pattern pattern)] + body)) + (partition 2 branches))))) + +(defmacro |let [bindings body] + (reduce (fn [inner [left right]] + `(|case ~right + ~left + ~inner)) + body + (reverse (partition 2 bindings)))) + +(defmacro |list [& elems] + (reduce (fn [tail head] + `($Cons ~head ~tail)) + `$Nil + (reverse elems))) + +(defmacro |table [& elems] + (reduce (fn [table [k v]] + `(|put ~k ~v ~table)) + `$Nil + (reverse (partition 2 elems)))) + +(defn |get [slot table] + (|case table + ($Nil) + nil + + ($Cons [k v] table*) + (if (.equals ^Object k slot) + v + (recur slot table*)))) + +(defn |put [slot value table] + (|case table + ($Nil) + ($Cons (T [slot value]) $Nil) + + ($Cons [k v] table*) + (if (.equals ^Object k slot) + ($Cons (T [slot value]) table*) + ($Cons (T [k v]) (|put slot value table*))) + )) + +(defn |remove [slot table] + (|case table + ($Nil) + table + + ($Cons [k v] table*) + (if (.equals ^Object k slot) + table* + ($Cons (T [k v]) (|remove slot table*))))) + +(defn |update [k f table] + (|case table + ($Nil) + table + + ($Cons [k* v] table*) + (if (.equals ^Object k k*) + ($Cons (T [k* (f v)]) table*) + ($Cons (T [k* v]) (|update k f table*))))) + +(defn |head [xs] + (|case xs + ($Nil) + (assert false (prn-str '|head)) + + ($Cons x _) + x)) + +(defn |tail [xs] + (|case xs + ($Nil) + (assert false (prn-str '|tail)) + + ($Cons _ xs*) + xs*)) + +;; [Resources/Monads] +(defn fail [message] + (fn [_] + ($Left message))) + +(defn return [value] + (fn [state] + ($Right (T [state value])))) + +(defn bind [m-value step] + (fn [state] + (let [inputs (m-value state)] + (|case inputs + ($Right ?state ?datum) + ((step ?datum) ?state) + + ($Left _) + inputs + )))) + +(defmacro |do [steps return] + (assert (= 0 (rem (count steps) 2)) "The number of steps must be even!") + (reduce (fn [inner [label computation]] + (case label + :let `(|let ~computation ~inner) + ;; else + `(bind ~computation + (fn [val#] + (|case val# + ~label + ~inner))))) + return + (reverse (partition 2 steps)))) + +;; [Resources/Combinators] +(let [array-class (class (to-array []))] + (defn adt->text [adt] + (if (= array-class (class adt)) + (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") + (pr-str adt)))) + +(defn |++ [xs ys] + (|case xs + ($Nil) + ys + + ($Cons x xs*) + ($Cons x (|++ xs* ys)))) + +(defn |map [f xs] + (|case xs + ($Nil) + xs + + ($Cons x xs*) + ($Cons (f x) (|map f xs*)) + + _ + (assert false (prn-str '|map f (adt->text xs))))) + +(defn |empty? [xs] + "(All [a] (-> (List a) Bool))" + (|case xs + ($Nil) + true + + ($Cons _ _) + false)) + +(defn |filter [p xs] + "(All [a] (-> (-> a Bool) (List a) (List a)))" + (|case xs + ($Nil) + xs + + ($Cons x xs*) + (if (p x) + ($Cons x (|filter p xs*)) + (|filter p xs*)))) + +(defn flat-map [f xs] + "(All [a b] (-> (-> a (List b)) (List a) (List b)))" + (|case xs + ($Nil) + xs + + ($Cons x xs*) + (|++ (f x) (flat-map f xs*)))) + +(defn |split-with [p xs] + (|case xs + ($Nil) + (T [xs xs]) + + ($Cons x xs*) + (if (p x) + (|let [[pre post] (|split-with p xs*)] + (T [($Cons x pre) post])) + (T [$Nil xs])))) + +(defn |contains? [k table] + (|case table + ($Nil) + false + + ($Cons [k* _] table*) + (or (.equals ^Object k k*) + (|contains? k table*)))) + +(defn |member? [x xs] + (|case xs + ($Nil) + false + + ($Cons x* xs*) + (or (= x x*) (|member? x xs*)))) + +(defn fold [f init xs] + (|case xs + ($Nil) + init + + ($Cons x xs*) + (recur f (f init x) xs*))) + +(defn fold% [f init xs] + (|case xs + ($Nil) + (return init) + + ($Cons x xs*) + (|do [init* (f init x)] + (fold% f init* xs*)))) + +(defn folds [f init xs] + (|case xs + ($Nil) + (|list init) + + ($Cons x xs*) + ($Cons init (folds f (f init x) xs*)))) + +(defn |length [xs] + (fold (fn [acc _] (inc acc)) 0 xs)) + +(defn |range* [from to] + (if (<= from to) + ($Cons from (|range* (inc from) to)) + $Nil)) + +(let [|range* (fn |range* [from to] + (if (< from to) + ($Cons from (|range* (inc from) to)) + $Nil))] + (defn |range [n] + (|range* 0 n))) + +(defn |first [pair] + (|let [[_1 _2] pair] + _1)) + +(defn |second [pair] + (|let [[_1 _2] pair] + _2)) + +(defn zip2 [xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + ($Cons (T [x y]) (zip2 xs* ys*)) + + [_ _] + $Nil)) + +(defn |keys [plist] + (|case plist + ($Nil) + $Nil + + ($Cons [k v] plist*) + ($Cons k (|keys plist*)))) + +(defn |vals [plist] + (|case plist + ($Nil) + $Nil + + ($Cons [k v] plist*) + ($Cons v (|vals plist*)))) + +(defn |interpose [sep xs] + (|case xs + ($Nil) + xs + + ($Cons _ ($Nil)) + xs + + ($Cons x xs*) + ($Cons x ($Cons sep (|interpose sep xs*))))) + +(do-template [ ] + (defn [f xs] + (|case xs + ($Nil) + (return xs) + + ($Cons x xs*) + (|do [y (f x) + ys ( f xs*)] + (return ( y ys))))) + + map% $Cons + flat-map% |++) + +(defn list-join [xss] + (fold |++ $Nil xss)) + +(defn |as-pairs [xs] + (|case xs + ($Cons x ($Cons y xs*)) + ($Cons (T [x y]) (|as-pairs xs*)) + + _ + $Nil)) + +(defn |reverse [xs] + (fold (fn [tail head] + ($Cons head tail)) + $Nil + xs)) + +(defn add-loc [meta ^String msg] + (if (.startsWith msg "@") + msg + (|let [[file line col] meta] + (str "@ " file "," line "," col "\n" msg)))) + +(defn fail-with-loc [msg] + (fn [state] + (fail* (add-loc (get$ $cursor state) msg)))) + +(defn assert! [test message] + (if test + (return unit-tag) + (fail-with-loc message))) + +(def get-state + (fn [state] + (return* state state))) + +(defn try-all% [monads] + (|case monads + ($Nil) + (fail "There are no alternatives to try!") + + ($Cons m monads*) + (fn [state] + (let [output (m state)] + (|case [output monads*] + [($Right _) _] + output + + [_ ($Nil)] + output + + [_ _] + ((try-all% monads*) state) + ))) + )) + +(defn try-all-% [prefix monads] + (|case monads + ($Nil) + (fail "There are no alternatives to try!") + + ($Cons m monads*) + (fn [state] + (let [output (m state)] + (|case [output monads*] + [($Right _) _] + output + + [_ ($Nil)] + output + + [($Left ^String error) _] + (if (.contains error prefix) + ((try-all-% prefix monads*) state) + output) + ))) + )) + +(defn exhaust% [step] + (fn [state] + (|case (step state) + ($Right state* _) + ((exhaust% step) state*) + + ($Left msg) + (if (.equals "[Reader Error] EOF" msg) + (return* state unit-tag) + (fail* msg))))) + +(defn ^:private normalize-char [char] + (case char + \* "_ASTER_" + \+ "_PLUS_" + \- "_DASH_" + \/ "_SLASH_" + \\ "_BSLASH_" + \_ "_UNDERS_" + \% "_PERCENT_" + \$ "_DOLLAR_" + \' "_QUOTE_" + \` "_BQUOTE_" + \@ "_AT_" + \^ "_CARET_" + \& "_AMPERS_" + \= "_EQ_" + \! "_BANG_" + \? "_QM_" + \: "_COLON_" + \. "_PERIOD_" + \, "_COMMA_" + \< "_LT_" + \> "_GT_" + \~ "_TILDE_" + \| "_PIPE_" + ;; default + char)) + +(defn normalize-name [ident] + (reduce str "" (map normalize-char ident))) + +(def classes + (fn [state] + (return* state (->> state (get$ $host) (get$ $classes))))) + +(def +init-bindings+ + (T [;; "lux;counter" + 0 + ;; "lux;mappings" + (|table)])) + +(defn env [name old-name] + (T [;; "lux;name" + ($Cons name old-name) + ;; "lux;inner-closures" + 0 + ;; "lux;locals" + +init-bindings+ + ;; "lux;closure" + +init-bindings+] + )) + +(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String + (class (byte-array [])) + Integer/TYPE + Integer/TYPE])) + (.setAccessible true))] + (defn memory-class-loader [store] + (proxy [java.lang.ClassLoader] + [] + (findClass [^String class-name] + (if-let [^bytes bytecode (get @store class-name)] + (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) + (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))) + +(def loader + (fn [state] + (return* state (->> state (get$ $host) (get$ $loader))))) + +(defn host [_] + (let [store (atom {})] + (T [;; "lux;writer" + $None + ;; "lux;loader" + (memory-class-loader store) + ;; "lux;classes" + store + ;; "lux;catching" + $Nil + ;; "lux;module-states" + (|table) + ;; lux;type-env + (|table) + ;; lux;dummy-mappings + (|table) + ]))) + +(defn with-no-catches [body] + "(All [a] (-> (Lux a) (Lux a)))" + (fn [state] + (let [old-catching (->> state (get$ $host) (get$ $catching))] + (|case (body (update$ $host #(set$ $catching $Nil %) state)) + ($Right state* output) + (return* (update$ $host #(set$ $catching old-catching %) state*) output) + + ($Left msg) + (fail* msg))))) + +(defn default-compiler-info [mode] + (T [;; compiler-name + compiler-name + ;; compiler-version + compiler-version + ;; compiler-mode + mode] + )) + +(defn init-state [mode] + (T [;; "lux;info" + (default-compiler-info mode) + ;; "lux;source" + $Nil + ;; "lux;cursor" + (T ["" -1 -1]) + ;; "lux;modules" + (|table) + ;; "lux;scopes" + $Nil + ;; "lux;types" + +init-bindings+ + ;; "lux;expected" + $None + ;; "lux;seed" + 0 + ;; scope-type-vars + $Nil + ;; "lux;host" + (host nil)] + )) + +(defn save-module [body] + (fn [state] + (|case (body state) + ($Right state* output) + (return* (->> state* + (set$ $scopes (get$ $scopes state)) + (set$ $source (get$ $source state))) + output) + + ($Left msg) + (fail* msg)))) + +(defn in-eval? [mode] + "(-> CompilerMode Bool)" + (|case mode + ($Eval) true + _ false)) + +(defn in-repl? [mode] + "(-> CompilerMode Bool)" + (|case mode + ($REPL) true + _ false)) + +(defn with-eval [body] + (fn [state] + (let [old-mode (->> state (get$ $info) (get$ $compiler-mode))] + (|case (body (update$ $info #(set$ $compiler-mode $Eval %) state)) + ($Right state* output) + (return* (update$ $info #(set$ $compiler-mode old-mode %) state*) output) + + ($Left msg) + (fail* msg))))) + +(def get-eval + (fn [state] + (return* state (->> state (get$ $info) (get$ $compiler-mode) in-eval?)))) + +(def get-mode + (fn [state] + (return* state (->> state (get$ $info) (get$ $compiler-mode))))) + +(def get-writer + (fn [state] + (let [writer* (->> state (get$ $host) (get$ $writer))] + (|case writer* + ($Some datum) + (return* state datum) + + _ + ((fail-with-loc "Writer hasn't been set.") state))))) + +(def get-top-local-env + (fn [state] + (try (let [top (|head (get$ $scopes state))] + (return* state top)) + (catch Throwable _ + ((fail-with-loc "No local environment.") state))))) + +(def gen-id + (fn [state] + (let [seed (get$ $seed state)] + (return* (set$ $seed (inc seed) state) seed)))) + +(defn ->seq [xs] + (|case xs + ($Nil) + (list) + + ($Cons x xs*) + (cons x (->seq xs*)))) + +(defn ->list [seq] + (if (empty? seq) + $Nil + ($Cons (first seq) (->list (rest seq))))) + +(defn |repeat [n x] + (if (> n 0) + ($Cons x (|repeat (dec n) x)) + $Nil)) + +(def get-module-name + (fn [state] + (|case (|reverse (get$ $scopes state)) + ($Nil) + ((fail-with-loc "[Analyser Error] Can't get the module-name without a module.") state) + + ($Cons ?global _) + (return* state (|head (get$ $name ?global)))))) + +(defn find-module [name] + "(-> Text (Lux (Module Compiler)))" + (fn [state] + (if-let [module (|get name (get$ $modules state))] + (return* state module) + ((fail-with-loc (str "[Error] Unknown module: " name)) state)))) + +(def get-current-module + "(Lux (Module Compiler))" + (|do [module-name get-module-name] + (find-module module-name))) + +(defn with-scope [name body] + (fn [state] + (let [old-name (->> state (get$ $scopes) |head (get$ $name)) + output (body (update$ $scopes #($Cons (env name old-name) %) state))] + (|case output + ($Right state* datum) + (return* (update$ $scopes |tail state*) datum) + + _ + output)))) + +(defn run-state [monad state] + (monad state)) + +(defn with-closure [body] + (|do [closure-name (|do [top get-top-local-env] + (return (->> top (get$ $inner-closures) str)))] + (fn [state] + (let [body* (with-scope closure-name body)] + (run-state body* (update$ $scopes #($Cons (update$ $inner-closures inc (|head %)) + (|tail %)) + state)))))) + +(defn without-repl-closure [body] + (|do [_mode get-mode] + (fn [state] + (let [output (body (if (in-repl? _mode) + (update$ $scopes |tail state) + state))] + (|case output + ($Right state* datum) + (return* (set$ $scopes (get$ $scopes state) state*) datum) + + _ + output))))) + +(defn without-repl [body] + (|do [_mode get-mode] + (fn [state] + (let [output (body (if (in-repl? _mode) + (update$ $info #(set$ $compiler-mode $Debug %) state) + state))] + (|case output + ($Right state* datum) + (return* (update$ $info #(set$ $compiler-mode _mode %) state*) datum) + + _ + output))))) + +(def get-scope-name + (fn [state] + (return* state (->> state (get$ $scopes) |head (get$ $name))))) + +(defn with-writer [writer body] + (fn [state] + (let [old-writer (->> state (get$ $host) (get$ $writer)) + output (body (update$ $host #(set$ $writer ($Some writer) %) state))] + (|case output + ($Right ?state ?value) + (return* (update$ $host #(set$ $writer old-writer %) ?state) + ?value) + + _ + output)))) + +(defn with-expected-type [type body] + "(All [a] (-> Type (Lux a)))" + (fn [state] + (let [output (body (set$ $expected ($Some type) state))] + (|case output + ($Right ?state ?value) + (return* (set$ $expected (get$ $expected state) ?state) + ?value) + + _ + output)))) + +(defn with-cursor [^objects cursor body] + "(All [a] (-> Cursor (Lux a)))" + (|let [[_file-name _ _] cursor] + (if (= "" _file-name) + body + (fn [state] + (let [output (body (set$ $cursor cursor state))] + (|case output + ($Right ?state ?value) + (return* (set$ $cursor (get$ $cursor state) ?state) + ?value) + + _ + output)))))) + +(defn with-analysis-meta [^objects cursor type body] + "(All [a] (-> Cursor Type (Lux a)))" + (|let [[_file-name _ _] cursor] + (if (= "" _file-name) + (fn [state] + (let [output (body (->> state + (set$ $expected ($Some type))))] + (|case output + ($Right ?state ?value) + (return* (->> ?state + (set$ $expected (get$ $expected state))) + ?value) + + _ + output))) + (fn [state] + (let [output (body (->> state + (set$ $cursor cursor) + (set$ $expected ($Some type))))] + (|case output + ($Right ?state ?value) + (return* (->> ?state + (set$ $cursor (get$ $cursor state)) + (set$ $expected (get$ $expected state))) + ?value) + + _ + output)))))) + +(def ensure-statement + "(Lux Unit)" + (fn [state] + (|case (get$ $expected state) + ($None) + (return* state unit-tag) + + ($Some _) + ((fail-with-loc "[Error] All statements must be top-level forms.") state)))) + +(def cursor + ;; (Lux Cursor) + (fn [state] + (return* state (get$ $cursor state)))) + +(let [remove-trailing-0s (fn [^String input] + (-> input + (.split "0*$") + (aget 0))) + make-text-start-0 (fn [input] + (loop [accum "" + range 10] + (if (< input range) + (recur (.concat accum "0") + (* 10 range)) + accum))) + count-bin-start-0 (fn [input] + (loop [counter 0 + idx 63] + (if (and (> idx -1) + (not (bit-test input idx))) + (recur (inc counter) + (dec idx)) + counter))) + read-frac-text (fn [^String input] + (let [output* (.split input "0*$")] + (if (= 0 (alength output*)) + (Long/parseUnsignedLong (aget output* 0)) + (Long/parseUnsignedLong input)))) + count-leading-0s (fn [^String input] + (let [parts (.split input "^0*")] + (if (= 2 (alength parts)) + (.length ^String (aget parts 0)) + 0)))] + (defn encode-frac [input] + (if (= 0 input) + ".0" + (let [^String prefix (->> (count-bin-start-0 input) + (bit-shift-left 1) + (make-text-start-0))] + (->> input + (Long/toUnsignedString) + remove-trailing-0s + (.concat prefix))))) + + (defn decode-frac [input] + (if-let [[_ frac-text] (re-find #"^\.(.+)$" input)] + (let [output* (-> frac-text + (string/replace #",_" "") + read-frac-text) + rows-to-move-forward (count-bin-start-0 output*) + scaling-factor (long (Math/pow 10.0 (double (count-leading-0s input))))] + (-> output* + (bit-shift-left rows-to-move-forward) + (/ scaling-factor))) + (assert false (str "Invalid Frac syntax: " input)))) + ) + +(defn show-ast [ast] + (|case ast + [_ ($BoolS ?value)] + (pr-str ?value) + + [_ ($NatS ?value)] + (str "+" (Long/toUnsignedString ?value)) + + [_ ($IntS ?value)] + (pr-str ?value) + + [_ ($FracS ?value)] + (encode-frac ?value) + + [_ ($RealS ?value)] + (pr-str ?value) + + [_ ($CharS ?value)] + (str "#\"" (pr-str ?value) "\"") + + [_ ($TextS ?value)] + (str "\"" ?value "\"") + + [_ ($TagS ?module ?tag)] + (if (.equals "" ?module) + (str "#" ?tag) + (str "#" ?module ";" ?tag)) + + [_ ($SymbolS ?module ?name)] + (if (.equals "" ?module) + ?name + (str ?module ";" ?name)) + + [_ ($TupleS ?elems)] + (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") + + [_ ($RecordS ?elems)] + (str "{" (->> ?elems + (|map (fn [elem] + (|let [[k v] elem] + (str (show-ast k) " " (show-ast v))))) + (|interpose " ") (fold str "")) "}") + + [_ ($FormS ?elems)] + (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") + + _ + (assert false (prn-str 'show-ast (adt->text ast))) + )) + +(defn ident->text [ident] + (|let [[?module ?name] ident] + (if (= "" ?module) + ?name + (str ?module ";" ?name)))) + +(defn fold2% [f init xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + (|do [init* (f init x y)] + (fold2% f init* xs* ys*)) + + [($Nil) ($Nil)] + (return init) + + [_ _] + (assert false "Lists don't match in size."))) + +(defn map2% [f xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + (|do [z (f x y) + zs (map2% f xs* ys*)] + (return ($Cons z zs))) + + [($Nil) ($Nil)] + (return $Nil) + + [_ _] + (assert false "Lists don't match in size."))) + +(defn map2 [f xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + ($Cons (f x y) (map2 f xs* ys*)) + + [_ _] + $Nil)) + +(defn fold2 [f init xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + (and init + (fold2 f (f init x y) xs* ys*)) + + [($Nil) ($Nil)] + init + + [_ _] + init + ;; (assert false) + )) + +(defn ^:private enumerate* [idx xs] + "(All [a] (-> Int (List a) (List (, Int a))))" + (|case xs + ($Cons x xs*) + ($Cons (T [idx x]) + (enumerate* (inc idx) xs*)) + + ($Nil) + xs + )) + +(defn enumerate [xs] + "(All [a] (-> (List a) (List (, Int a))))" + (enumerate* 0 xs)) + +(def modules + "(Lux (List Text))" + (fn [state] + (return* state (|keys (get$ $modules state))))) + +(defn when% [test body] + "(-> Bool (Lux Unit) (Lux Unit))" + (if test + body + (return unit-tag))) + +(defn |at [idx xs] + "(All [a] (-> Int (List a) (Maybe a)))" + (|case xs + ($Cons x xs*) + (cond (< idx 0) + $None + + (= idx 0) + ($Some x) + + :else ;; > 1 + (|at (dec idx) xs*)) + + ($Nil) + $None + )) + +(defn normalize [ident] + "(-> Ident (Lux Ident))" + (|case ident + ["" name] (|do [module get-module-name] + (return (T [module name]))) + _ (return ident))) + +(defn ident= [x y] + (|let [[xmodule xname] x + [ymodule yname] y] + (and (= xmodule ymodule) + (= xname yname)))) + +(defn |list-put [idx val xs] + (|case xs + ($Nil) + $None + + ($Cons x xs*) + (if (= idx 0) + ($Some ($Cons val xs*)) + (|case (|list-put (dec idx) val xs*) + ($None) $None + ($Some xs**) ($Some ($Cons x xs**))) + ))) + +(do-template [ ] + (do (defn [module] + "(-> Text (Lux Unit))" + (fn [state] + (let [state* (update$ $host (fn [host] + (update$ $module-states + (fn [module-states] + (|put module module-states)) + host)) + state)] + ($Right (T [state* unit-tag]))))) + (defn [module] + "(-> Text (Lux Bool))" + (fn [state] + (if-let [module-state (->> state (get$ $host) (get$ $module-states) (|get module))] + ($Right (T [state (|case module-state + () true + _ false)])) + ($Right (T [state false]))) + ))) + + flag-active-module active-module? $Active + flag-compiled-module compiled-module? $Compiled + flag-cached-module cached-module? $Cached + ) + +(do-template [ ] + (defn [p xs] + "(All [a] (-> (-> a Bool) (List a) Bool))" + (|case xs + ($Nil) + + + ($Cons x xs*) + ( (p x) ( p xs*)))) + + |every? true and + |any? false or) + +(defn m-comp [f g] + "(All [a b c] (-> (-> b (Lux c)) (-> a (Lux b)) (-> a (Lux c))))" + (fn [x] + (|do [y (g x)] + (f y)))) + +(defn with-attempt [m-value on-error] + "(All [a] (-> (Lux a) (-> Text (Lux a)) (Lux a)))" + (fn [state] + (|case (m-value state) + ($Left msg) + ((on-error msg) state) + + output + output))) + +(defn |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*) + output output) + )) + +(def get-type-env + "(Lux TypeEnv)" + (fn [state] + (return* state (->> state (get$ $host) (get$ $type-env))))) + +(defn with-type-env [type-env body] + "(All [a] (-> TypeEnv (Lux a) (Lux a)))" + (fn [state] + (|let [state* (update$ $host #(update$ $type-env (partial |++ type-env) %) + state)] + (|case (body state*) + ($Right [state** output]) + ($Right (T [(update$ $host + #(set$ $type-env + (->> state (get$ $host) (get$ $type-env)) + %) + state**) + output])) + + ($Left msg) + ($Left msg))))) + +(defn |take [n xs] + (|case (T [n xs]) + [0 _] $Nil + [_ ($Nil)] $Nil + [_ ($Cons x xs*)] ($Cons x (|take (dec n) xs*)) + )) + +(defn |drop [n xs] + (|case (T [n xs]) + [0 _] xs + [_ ($Nil)] $Nil + [_ ($Cons x xs*)] (|drop (dec n) xs*) + )) + +(defn |but-last [xs] + (|case xs + ($Nil) + $Nil + + ($Cons x ($Nil)) + $Nil + + ($Cons x xs*) + ($Cons x (|but-last xs*)) + + _ + (assert false (adt->text xs)))) + +(defn |last [xs] + (|case xs + ($Cons x ($Nil)) + x + + ($Cons x xs*) + (|last xs*) + + _ + (assert false (adt->text xs)))) + +(defn |partition [n xs] + (->> xs ->seq (partition-all n) (map ->list) ->list)) + +(defn with-scope-type-var [id body] + (fn [state] + (|case (body (set$ $scope-type-vars + ($Cons id (get$ $scope-type-vars state)) + state)) + ($Right [state* output]) + ($Right (T [(set$ $scope-type-vars + (get$ $scope-type-vars state) + state*) + output])) + + ($Left msg) + ($Left msg)))) + +(defn push-dummy-name [real-name store-name] + (fn [state] + ($Right (T [(update$ $host + #(update$ $dummy-mappings + (partial $Cons (T [real-name store-name])) + %) + state) + nil])))) + +(def pop-dummy-name + (fn [state] + ($Right (T [(update$ $host + #(update$ $dummy-mappings + |tail + %) + state) + nil])))) + +(defn de-alias-class [class-name] + (fn [state] + ($Right (T [state + (|case (|some #(|let [[real-name store-name] %] + (if (= real-name class-name) + ($Some store-name) + $None)) + (->> state (get$ $host) (get$ $dummy-mappings))) + ($Some store-name) + store-name + + _ + class-name)])))) + +(let [!out! *out*] + (defn |log! [& parts] + (binding [*out* !out!] + (do (print (apply str parts)) + (flush))))) diff --git a/luxc/src/lux/compiler.clj b/luxc/src/lux/compiler.clj new file mode 100644 index 000000000..d8c5e4571 --- /dev/null +++ b/luxc/src/lux/compiler.clj @@ -0,0 +1,268 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler + (:refer-clojure :exclude [compile]) + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]] + [type :as &type] + [reader :as &reader] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [optimizer :as &optimizer] + [host :as &host]) + [lux.host.generics :as &host-generics] + [lux.optimizer :as &o] + [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] + [lambda :as &&lambda] + [module :as &&module] + [io :as &&io] + [parallel :as &¶llel]) + (lux.compiler.cache [type :as &&&type] + [ann :as &&&ann])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Resources] +(def ^:private !source->last-line (atom nil)) + +(defn compile-expression [$begin syntax] + (|let [[[?type [_file-name _line _]] ?form] syntax] + (|do [^MethodVisitor *writer* &/get-writer + :let [debug-label (new Label) + _ (when (not= _line (get @!source->last-line _file-name)) + (doto *writer* + (.visitLabel debug-label) + (.visitLineNumber (int _line) debug-label)) + (swap! !source->last-line assoc _file-name _line))]] + (|case ?form + (&o/$bool ?value) + (&&lux/compile-bool ?value) + + (&o/$nat ?value) + (&&lux/compile-nat ?value) + + (&o/$int ?value) + (&&lux/compile-int ?value) + + (&o/$frac ?value) + (&&lux/compile-frac ?value) + + (&o/$real ?value) + (&&lux/compile-real ?value) + + (&o/$char ?value) + (&&lux/compile-char ?value) + + (&o/$text ?value) + (&&lux/compile-text ?value) + + (&o/$tuple ?elems) + (&&lux/compile-tuple (partial compile-expression $begin) ?elems) + + (&o/$var (&/$Local ?idx)) + (&&lux/compile-local (partial compile-expression $begin) ?idx) + + (&o/$captured ?scope ?captured-id ?source) + (&&lux/compile-captured (partial compile-expression $begin) ?scope ?captured-id ?source) + + (&o/$var (&/$Global ?owner-class ?name)) + (&&lux/compile-global (partial compile-expression $begin) ?owner-class ?name) + + (&o/$apply ?fn ?args) + (&&lux/compile-apply (partial compile-expression $begin) ?fn ?args) + + (&o/$loop _register-offset _inits _body) + (&&lux/compile-loop compile-expression _register-offset _inits _body) + + (&o/$iter _register-offset ?args) + (&&lux/compile-iter (partial compile-expression $begin) $begin _register-offset ?args) + + (&o/$variant ?tag ?tail ?members) + (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members) + + (&o/$case ?value [?pm ?bodies]) + (&&case/compile-case (partial compile-expression $begin) ?value ?pm ?bodies) + + (&o/$let _value _register _body) + (&&lux/compile-let (partial compile-expression $begin) _value _register _body) + + (&o/$record-get _value _path) + (&&lux/compile-record-get (partial compile-expression $begin) _value _path) + + (&o/$if _test _then _else) + (&&lux/compile-if (partial compile-expression $begin) _test _then _else) + + (&o/$function _register-offset ?arity ?scope ?env ?body) + (&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body) + + (&o/$ann ?value-ex ?type-ex) + (compile-expression $begin ?value-ex) + + (&o/$proc [?proc-category ?proc-name] ?args special-args) + (&&host/compile-host (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args) + + _ + (assert false (prn-str 'compile-expression (&/adt->text syntax))) + )) + )) + +(defn init! + "(-> (List Text) Null)" + [resources-dirs target-dir] + (do (reset! &&/!output-dir target-dir) + (&¶llel/setup!) + (reset! !source->last-line {}) + (.mkdirs (java.io.File. target-dir)) + (let [class-loader (ClassLoader/getSystemClassLoader) + addURL (doto (.getDeclaredMethod java.net.URLClassLoader "addURL" (into-array [java.net.URL])) + (.setAccessible true))] + (doseq [resources-dir (&/->seq resources-dirs)] + (.invoke addURL class-loader + (to-array [(->> resources-dir (new java.io.File) .toURI .toURL)])))))) + +(defn eval! [expr] + (&/with-eval + (|do [module &/get-module-name + id &/gen-id + [file-name _ _] &/cursor + :let [class-name (str (&host/->module-class module) "/" id) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + class-name nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitCode *writer*)] + _ (compile-expression nil expr) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [bytecode (.toByteArray (doto =class + .visitEnd))] + _ (&&/save-class! (str id) bytecode) + loader &/loader] + (-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id)) + (.getField &/eval-field) + (.get nil) + return)))) + +(def all-compilers + (let [compile-expression* (partial compile-expression nil)] + (&/T [(partial &&lux/compile-def compile-expression) + (partial &&lux/compile-program compile-expression*) + (partial &&host/compile-jvm-class compile-expression*) + &&host/compile-jvm-interface]))) + +(let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) + +datum-sig+ "Ljava/lang/Object;"] + (defn compile-module [source-dirs name] + (let [file-name (str name ".lux")] + (|do [file-content (&&io/read-file source-dirs file-name) + :let [file-hash (hash file-content) + ;; compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs)) + compile-module!! (partial compile-module source-dirs)]] + (if (&&cache/cached? name) + (&&cache/load source-dirs name file-hash compile-module!!) + (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (fail "[Compiler Error] Can't redefine a module!") + (|do [_ (&&cache/delete name) + _ (&a-module/create-module name file-hash) + _ (&/flag-active-module name) + :let [module-class-name (str (&host/->module-class name) "/_") + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + module-class-name nil "java/lang/Object" nil) + (-> (.visitField +field-flags+ &/hash-field "I" nil file-hash) + .visitEnd) + (-> (.visitField +field-flags+ &/compiler-field "Ljava/lang/String;" nil &/compiler-version) + .visitEnd) + (.visitSource file-name nil))] + _ (if (= "lux" name) + (|do [_ &&host/compile-Function-class + _ &&host/compile-LuxRT-class] + (return nil)) + (return nil))] + (fn [state] + (|case ((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$source (&reader/from name file-content) state)) + (&/$Right ?state _) + (&/run-state (|do [:let [_ (.visitEnd =class)] + module-anns (&a-module/get-anns name) + defs &a-module/defs + imports &a-module/imports + tag-groups &&module/tag-groups + :let [def-entries (->> defs + (&/|map (fn [_def] + (|let [[?name ?alias [?def-type ?def-anns ?def-value]] _def] + (if (= "" ?alias) + (str ?name &&/datum-separator (&&&type/serialize-type ?def-type) &&/datum-separator (&&&ann/serialize-anns ?def-anns)) + (str ?name &&/datum-separator ?alias))))) + (&/|interpose &&/entry-separator) + (&/fold str "")) + import-entries (->> imports + (&/|map (fn [import] + (|let [[_module _hash] import] + (str _module &&/datum-separator _hash)))) + (&/|interpose &&/entry-separator) + (&/fold str "")) + tag-entries (->> tag-groups + (&/|map (fn [group] + (|let [[type tags] group] + (->> tags + (&/|interpose &&/datum-separator) + (&/fold str "") + (str type &&/datum-separator))))) + (&/|interpose &&/entry-separator) + (&/fold str "")) + module-descriptor (->> (&/|list import-entries + tag-entries + (&&&ann/serialize-anns module-anns) + def-entries) + (&/|interpose &&/section-separator) + (&/fold str ""))] + _ (&/flag-compiled-module name) + _ (&&/save-class! &/module-class-name (.toByteArray =class)) + _ (&&/write-module-descriptor! name module-descriptor)] + (return file-hash)) + ?state) + + (&/$Left ?message) + (fail* ?message))))))) + )) + ))) + +(defn compile-program [mode program-module resources-dir source-dirs target-dir] + (do (init! resources-dir target-dir) + (let [m-action (|do [_ (compile-module source-dirs "lux")] + (compile-module source-dirs program-module))] + (|case (m-action (&/init-state mode)) + (&/$Right ?state _) + (do (println "Compilation complete!") + (&&cache/clean ?state)) + + (&/$Left ?message) + (assert false ?message))))) diff --git a/luxc/src/lux/compiler/base.clj b/luxc/src/lux/compiler/base.clj new file mode 100644 index 000000000..e57571fef --- /dev/null +++ b/luxc/src/lux/compiler/base.clj @@ -0,0 +1,116 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.base + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.java.io :as io] + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail*]] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &a] + [module :as &a-module]) + [lux.host.generics :as &host-generics]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor) + (java.io File + BufferedOutputStream + FileOutputStream) + (java.lang.reflect Field))) + +;; [Constants] +(def !output-dir (atom nil)) + +(def ^:const ^String function-class "lux/Function") +(def ^:const ^String lux-utils-class "lux/LuxRT") +(def ^:const ^String unit-tag-field "unit_tag") + +;; Formats +(def ^:const ^String local-prefix "l") +(def ^:const ^String partial-prefix "p") +(def ^:const ^String closure-prefix "c") +(def ^:const ^String apply-method "apply") +(defn ^String apply-signature [n] + (str "(" (apply str (repeat n "Ljava/lang/Object;")) ")Ljava/lang/Object;")) +(def ^:const num-apply-variants 8) +(def ^:const arity-field "_arity_") +(def ^:const partials-field "_partials_") + +(def ^:const section-separator (->> 29 char str)) +(def ^:const datum-separator (->> 31 char str)) +(def ^:const entry-separator (->> 30 char str)) + +;; [Utils] +(defn ^:private write-file [^String file-name ^bytes data] + (do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name)) + (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))] + (.write stream data)))) + +(defn ^:private write-output [module name data] + (let [module* (&host/->module-class module) + module-dir (str @!output-dir "/" module*)] + (.mkdirs (File. module-dir)) + (write-file (str module-dir "/" name ".class") data))) + +(defn class-exists? [^String module ^String class-name] + "(-> Text Text (IO Bool))" + (|do [_ (return nil) + :let [full-path (str @!output-dir "/" module "/" class-name ".class") + exists? (.exists (File. full-path))]] + (return exists?))) + +;; [Exports] +(defn ^Class load-class! [^ClassLoader loader name] + ;; (prn 'load-class! name) + (.loadClass loader name)) + +(defn save-class! [name bytecode] + (|do [eval? &/get-eval + module &/get-module-name + loader &/loader + !classes &/classes + :let [real-name (str (&host-generics/->class-name module) "." name) + _ (swap! !classes assoc real-name bytecode) + _ (when (not eval?) + (write-output module name bytecode)) + _ (load-class! loader real-name)]] + (return nil))) + +(def ^String lux-module-descriptor-name "lux_module_descriptor") + +(defn write-module-descriptor! [^String name ^String descriptor] + (|do [_ (return nil) + :let [lmd-dir (str @!output-dir "/" name) + _ (.mkdirs (File. lmd-dir)) + _ (write-file (str lmd-dir "/" lux-module-descriptor-name) (.getBytes descriptor java.nio.charset.StandardCharsets/UTF_8))]] + (return nil))) + +(defn read-module-descriptor! [^String name] + (|do [_ (return nil)] + (return (slurp (str @!output-dir "/" name "/" lux-module-descriptor-name) + :encoding "UTF-8")))) + +(do-template [ ] + (do (defn [^MethodVisitor writer] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str "(" ")" (&host-generics/->type-signature ))))) + (defn [^MethodVisitor writer] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST ) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (str "()" ))))) + + wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1 + wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1 + wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1 + wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1 + wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2 + wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1 + wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2 + wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1 + ) diff --git a/luxc/src/lux/compiler/cache.clj b/luxc/src/lux/compiler/cache.clj new file mode 100644 index 000000000..6c44e2a45 --- /dev/null +++ b/luxc/src/lux/compiler/cache.clj @@ -0,0 +1,188 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.cache + (:refer-clojure :exclude [load]) + (:require [clojure.string :as string] + [clojure.java.io :as io] + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |case |let]] + [type :as &type] + [host :as &host]) + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &a] + [module :as &a-module] + [meta :as &a-meta]) + (lux.compiler [base :as &&] + [io :as &&io]) + (lux.compiler.cache [type :as &&&type] + [ann :as &&&ann])) + (:import (java.io File + BufferedOutputStream + FileOutputStream) + (java.lang.reflect Field))) + +;; [Utils] +(defn ^:private read-file [^File file] + "(-> File (Array Byte))" + (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] + "(-> File (,))" + (doseq [^File f (seq (.listFiles file)) + :when (not (.isDirectory f))] + (.delete f))) + +(defn ^:private get-field [^String field-name ^Class class] + "(-> Text Class Object)" + (-> class ^Field (.getField field-name) (.get nil))) + +;; [Resources] +(def module-class (str &/module-class-name ".class")) + +(defn cached? [module] + "(-> Text Bool)" + (.exists (new File (str @&&/!output-dir "/" (&host/->module-class module) "/" module-class))) + ;; false + ) + +(defn delete [module] + "(-> Text (Lux Null))" + (fn [state] + (do (clean-file (new File (str @&&/!output-dir "/" (&host/->module-class module)))) + (return* state nil)))) + +(defn ^:private module-dirs + "(-> File (clojure.Seq File))" + [^File module] + (->> module + .listFiles + (filter #(.isDirectory %)) + (map module-dirs) + (apply concat) + (list* module))) + +(defn clean [state] + "(-> Compiler Null)" + (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) + output-dir-prefix (str (.getAbsolutePath (new File @&&/!output-dir)) "/") + outdated? #(->> % (contains? needed-modules) not) + outdated-modules (->> (new File @&&/!output-dir) + .listFiles (filter #(.isDirectory %)) + (map module-dirs) doall (apply concat) + (map #(-> ^File % .getAbsolutePath (string/replace output-dir-prefix ""))) + (filter outdated?))] + (doseq [^String f outdated-modules] + (clean-file (new File (str output-dir-prefix f)))) + nil)) + +(defn ^:private install-all-classes-in-module [!classes module* ^String module-path] + (doseq [^File file (seq (.listFiles (File. module-path))) + :when (not (.isDirectory file)) + :let [file-name (.getName file)] + :when (not= module-class file-name)] + (let [real-name (second (re-find #"^(.*)\.class$" file-name)) + bytecode (read-file file)] + (swap! !classes assoc (str module* "." real-name) bytecode)))) + +(defn ^:private assume-async-result + "(-> (Error Compiler) (Lux Null))" + [result] + (fn [_] + (|case result + (&/$Left error) + (&/$Left error) + + (&/$Right compiler) + (return* compiler nil)))) + +(defn load [source-dirs module module-hash compile-module] + "(-> (List Text) Text Int (-> Text (Lux (,))) (Lux Bool))" + (|do [already-loaded? (&a-module/exists? module)] + (if already-loaded? + (return module-hash) + (|let [redo-cache (|do [_ (delete module) + ;; async (compile-module module) + ] + ;; (assume-async-result @async) + (compile-module module))] + (if (cached? module) + (|do [loader &/loader + !classes &/classes + :let [module* (&host-generics/->class-name module) + module-path (str @&&/!output-dir "/" module) + class-name (str module* "._") + old-classes @!classes + ^Class module-class (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (&&/load-class! loader class-name)) + _ (install-all-classes-in-module !classes module* module-path)]] + (if (and (= module-hash (get-field &/hash-field module-class)) + (= &/compiler-version (get-field &/compiler-field module-class))) + (|do [^String descriptor (&&/read-module-descriptor! module) + :let [sections (.split descriptor &&/section-separator) + [^String imports-section ^String tags-section module-anns-section ^String defs-section] sections + imports (vec (.split imports-section &&/entry-separator))] + loads (&/map% (fn [^String _import] + (let [[_module _hash] (.split _import &&/datum-separator 2)] + (|do [file-content (&&io/read-file source-dirs (str _module ".lux")) + :let [file-hash (hash file-content) + __hash (Integer/parseInt _hash)] + _ (load source-dirs _module file-hash compile-module) + cached? (&/cached-module? _module) + :let [consistent-cache? (= file-hash __hash)]] + (return (and cached? + consistent-cache?))))) + (if (= [""] imports) + &/$Nil + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (|do [:let [tag-groups (if (= "" tags-section) + &/$Nil + (-> tags-section + (.split &&/entry-separator) + seq + (->> (map (fn [^String _group] + (let [[_type & _tags] (.split _group &&/datum-separator)] + (&/T [_type (->> _tags seq &/->list)]))))) + &/->list))] + _ (&a-module/create-module module module-hash) + _ (&a-module/set-anns (&&&ann/deserialize-anns module-anns-section) module) + _ (&/flag-cached-module module) + _ (&a-module/set-imports imports) + :let [desc-defs (vec (.split defs-section &&/entry-separator))] + _ (&/map% (fn [^String _def-entry] + (let [parts (.split _def-entry &&/datum-separator)] + (case (alength parts) + 2 (let [[_name _alias] parts + [_ __module __name] (re-find #"^(.*);(.*)$" _alias) + def-class (&&/load-class! loader (str (&host-generics/->class-name __module) "." (&host/def-name __name))) + def-type (&a-module/def-type __module __name) + def-anns (&/|list (&/T [&a-meta/alias-tag (&/$IdentM (&/T [__module __name]))])) + def-value (get-field &/value-field def-class)] + (&a-module/define module _name def-type def-anns def-value)) + 3 (let [[_name _type _anns] parts + def-class (&&/load-class! loader (str module* "." (&host/def-name _name))) + [def-anns _] (&&&ann/deserialize-anns _anns) + [def-type _] (&&&type/deserialize-type _type) + def-value (get-field &/value-field def-class)] + (&a-module/define module _name def-type def-anns def-value))))) + (if (= [""] desc-defs) + &/$Nil + (&/->list desc-defs))) + _ (&/map% (fn [group] + (|let [[_type _tags] group] + (|do [[was-exported? =type] (&a-module/type-def module _type)] + (&a-module/declare-tags module _tags was-exported? =type)))) + tag-groups)] + (return module-hash)) + redo-cache)) + (do (reset! !classes old-classes) + redo-cache))) + redo-cache))))) diff --git a/luxc/src/lux/compiler/cache/ann.clj b/luxc/src/lux/compiler/cache/ann.clj new file mode 100644 index 000000000..d50c02465 --- /dev/null +++ b/luxc/src/lux/compiler/cache/ann.clj @@ -0,0 +1,159 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.cache.ann + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]]))) + +(def ^:private stop (->> 7 char str)) +(def ^:private cons-signal (->> 5 char str)) +(def ^:private nil-signal (->> 6 char str)) +(def ^:private ident-separator ";") + +(defn ^:private serialize-seq [serialize-ann params] + (str (&/fold (fn [so-far param] + (str so-far cons-signal (serialize-ann param))) + "" + params) + nil-signal)) + +(defn ^:private serialize-text [value] + (str "T" value stop)) + +(defn ^:private serialize-ident [ident] + (|let [[module name] ident] + (str "@" module ident-separator name stop))) + +(defn serialize-ann + "(-> Ann-Value Text)" + [ann] + (|case ann + (&/$BoolM value) + (str "B" value stop) + + (&/$NatM value) + (str "N" value stop) + + (&/$IntM value) + (str "I" value stop) + + (&/$FracM value) + (str "F" value stop) + + (&/$RealM value) + (str "R" value stop) + + (&/$CharM value) + (str "C" value stop) + + (&/$TextM value) + (serialize-text value) + + (&/$IdentM ident) + (serialize-ident ident) + + (&/$ListM elems) + (str "L" (serialize-seq serialize-ann elems)) + + (&/$DictM kvs) + (str "D" (serialize-seq (fn [kv] + (|let [[k v] kv] + (str (serialize-text k) + (serialize-ann v)))) + kvs)) + + _ + (assert false) + )) + +(defn serialize-anns + "(-> Anns Text)" + [anns] + (serialize-seq (fn [kv] + (|let [[k v] kv] + (str (serialize-ident k) + (serialize-ann v)))) + anns)) + +(declare deserialize-ann) + +(do-template [ ] + (defn [^String input] + (when (.startsWith input ) + (let [[value* ^String input*] (.split (.substring input 1) stop 2)] + [( ( value*)) input*]))) + + ^:private deserialize-bool "B" &/$BoolM Boolean/parseBoolean + ^:private deserialize-nat "N" &/$NatM Long/parseLong + ^:private deserialize-int "I" &/$IntM Long/parseLong + ^:private deserialize-frac "F" &/$FracM Long/parseLong + ^:private deserialize-real "R" &/$RealM Double/parseDouble + ^:private deserialize-char "C" &/$CharM (fn [^String input] (.charAt input 0)) + ^:private deserialize-text "T" &/$TextM identity + ) + +(defn ^:private deserialize-ident* [^String input] + (when (.startsWith input "@") + (let [[ident* ^String input*] (.split (.substring input 1) stop 2) + [_module _name] (.split ident* ident-separator 2)] + [(&/T [_module _name]) input*]))) + +(defn ^:private deserialize-ident [^String input] + (when (.startsWith input "@") + (let [[ident* ^String input*] (.split (.substring input 1) stop 2) + [_module _name] (.split ident* ident-separator 2)] + [(&/$IdentM (&/T [_module _name])) input*]))) + +(defn ^:private deserialize-seq [deserializer input] + (cond (.startsWith input nil-signal) + [&/$Nil (.substring input 1)] + + (.startsWith input cons-signal) + (when-let [[head ^String input*] (deserializer (.substring input 1))] + (when-let [[tail ^String input*] (deserialize-seq deserializer input*)] + [(&/$Cons head tail) input*])) + )) + +(do-template [ ] + (defn [input] + (when-let [[key input*] ( input)] + (when-let [[ann input*] (deserialize-ann input*)] + [(&/T [key ann]) input*]))) + + ^:private deserialize-kv deserialize-text + ^:private deserialize-ann-entry deserialize-ident* + ) + +(do-template [ ] + (defn [^String input] + (when (.startsWith input ) + (when-let [[elems ^String input*] (deserialize-seq + (.substring input 1))] + [( elems) input*]))) + + ^:private deserialize-list "L" &/$ListM deserialize-ann + ^:private deserialize-dict "D" &/$DictM deserialize-kv + ) + +(defn ^:private deserialize-ann + "(-> Text Anns)" + [input] + (or (deserialize-bool input) + (deserialize-nat input) + (deserialize-int input) + (deserialize-frac input) + (deserialize-real input) + (deserialize-char input) + (deserialize-text input) + (deserialize-ident input) + (deserialize-list input) + (deserialize-dict input) + (assert false "[Cache error] Can't deserialize annocation."))) + +(defn deserialize-anns [^String input] + (deserialize-seq deserialize-ann-entry input)) diff --git a/luxc/src/lux/compiler/cache/type.clj b/luxc/src/lux/compiler/cache/type.clj new file mode 100644 index 000000000..80d3a93d6 --- /dev/null +++ b/luxc/src/lux/compiler/cache/type.clj @@ -0,0 +1,164 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.cache.type + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]] + [type :as &type]))) + +(def ^:private stop (->> 7 char str)) +(def ^:private cons-signal (->> 5 char str)) +(def ^:private nil-signal (->> 6 char str)) +(def ^:private ident-separator ";") + +(defn ^:private serialize-list [serialize-type params] + (str (&/fold (fn [so-far param] + (str so-far cons-signal (serialize-type param))) + "" + params) + nil-signal)) + +(defn serialize-type + "(-> Type Text)" + [type] + (if (clojure.lang.Util/identical &type/Type type) + "T" + (|case type + (&/$HostT name params) + (str "^" name stop (serialize-list serialize-type params)) + + (&/$VoidT) + "0" + + (&/$UnitT) + "1" + + (&/$ProdT left right) + (str "*" (serialize-type left) (serialize-type right)) + + (&/$SumT left right) + (str "+" (serialize-type left) (serialize-type right)) + + (&/$LambdaT left right) + (str ">" (serialize-type left) (serialize-type right)) + + (&/$UnivQ env body) + (str "U" (serialize-list serialize-type env) (serialize-type body)) + + (&/$ExQ env body) + (str "E" (serialize-list serialize-type env) (serialize-type body)) + + (&/$BoundT idx) + (str "$" idx stop) + + (&/$ExT idx) + (str "!" idx stop) + + (&/$VarT idx) + (str "?" idx stop) + + (&/$AppT left right) + (str "%" (serialize-type left) (serialize-type right)) + + (&/$NamedT [module name] type*) + (str "@" module ident-separator name stop (serialize-type type*)) + + _ + (assert false (prn 'serialize-type (&type/show-type type))) + ))) + +(declare deserialize-type) + +(defn ^:private deserialize-list [input] + (cond (.startsWith input nil-signal) + [&/$Nil (.substring input 1)] + + (.startsWith input cons-signal) + (when-let [[head ^String input*] (deserialize-type (.substring input 1))] + (when-let [[tail ^String input*] (deserialize-list input*)] + [(&/$Cons head tail) input*])) + )) + +(do-template [ ] + (defn [^String input] + (when (.startsWith input ) + [ (.substring input 1)] + )) + + ^:private deserialize-void "0" &/$VoidT + ^:private deserialize-unit "1" &/$UnitT + ^:private deserialize-type* "T" &type/Type + ) + +(do-template [ ] + (defn [^String input] + (when (.startsWith input ) + (when-let [[left ^String input*] (deserialize-type (.substring input 1))] + (when-let [[right ^String input*] (deserialize-type input*)] + [( left right) input*])) + )) + + ^:private deserialize-sum "+" &/$SumT + ^:private deserialize-prod "*" &/$ProdT + ^:private deserialize-lambda ">" &/$LambdaT + ^:private deserialize-app "%" &/$AppT + ) + +(do-template [ ] + (defn [^String input] + (when (.startsWith input ) + (let [[idx ^String input*] (.split (.substring input 1) stop 2)] + [( (Long/parseLong idx)) input*]))) + + ^:private deserialize-bound "$" &/$BoundT + ^:private deserialize-ex "!" &/$ExT + ^:private deserialize-var "?" &/$VarT + ) + +(defn ^:private deserialize-named [^String input] + (when (.startsWith input "@") + (let [[^String module+name ^String input*] (.split (.substring input 1) stop 2) + [module name] (.split module+name ident-separator 2)] + (when-let [[type* ^String input*] (deserialize-type input*)] + [(&/$NamedT (&/T [module name]) type*) input*])))) + +(do-template [ ] + (defn [^String input] + (when (.startsWith input ) + (when-let [[env ^String input*] (deserialize-list (.substring input 1))] + (when-let [[body ^String input*] (deserialize-type input*)] + [( env body) input*])))) + + ^:private deserialize-univq "U" &/$UnivQ + ^:private deserialize-exq "E" &/$ExQ + ) + +(defn ^:private deserialize-host [^String input] + (when (.startsWith input "^") + (let [[name ^String input*] (.split (.substring input 1) stop 2)] + (when-let [[params ^String input*] (deserialize-list input*)] + [(&/$HostT name params) input*])))) + +(defn deserialize-type + "(-> Text Type)" + [input] + (or (deserialize-type* input) + (deserialize-void input) + (deserialize-unit input) + (deserialize-sum input) + (deserialize-prod input) + (deserialize-lambda input) + (deserialize-app input) + (deserialize-bound input) + (deserialize-ex input) + (deserialize-var input) + (deserialize-named input) + (deserialize-univq input) + (deserialize-exq input) + (deserialize-host input) + (assert false (str "[Cache error] Can't deserialize type. --- " input)))) diff --git a/luxc/src/lux/compiler/case.clj b/luxc/src/lux/compiler/case.clj new file mode 100644 index 000000000..afdcd3eed --- /dev/null +++ b/luxc/src/lux/compiler/case.clj @@ -0,0 +1,219 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.case + (:require (clojure [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + [lux.analyser.case :as &a-case] + [lux.compiler.base :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Utils] +(defn ^:private pop-alt-stack [^MethodVisitor writer stack-depth] + (cond (= 0 stack-depth) + writer + + (= 1 stack-depth) + (doto writer + (.visitInsn Opcodes/POP)) + + (= 2 stack-depth) + (doto writer + (.visitInsn Opcodes/POP2)) + + :else ;; > 2 + (doto writer + (.visitInsn Opcodes/POP2) + (pop-alt-stack (- stack-depth 2))))) + +(defn ^:private stack-peek [^MethodVisitor writer] + (doto writer + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;"))) + +(defn ^:private compile-pattern* [^MethodVisitor writer bodies stack-depth $else pm] + "(-> MethodVisitor Case-Pattern (List Label) Int Label MethodVisitor)" + (|case pm + (&o/$ExecPM _body-idx) + (|case (&/|at _body-idx bodies) + (&/$Some $body) + (doto writer + (pop-alt-stack stack-depth) + (.visitJumpInsn Opcodes/GOTO $body)) + + (&/$None) + (assert false)) + + (&o/$PopPM) + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;")) + + (&o/$BindPM _var-id) + (doto writer + stack-peek + (.visitVarInsn Opcodes/ASTORE _var-id) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;")) + + (&o/$BoolPM _value) + (doto writer + stack-peek + &&/unwrap-boolean + (.visitJumpInsn (if _value Opcodes/IFEQ Opcodes/IFNE) $else)) + + (&o/$NatPM _value) + (doto writer + stack-peek + &&/unwrap-long + (.visitLdcInsn (long _value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$IntPM _value) + (doto writer + stack-peek + &&/unwrap-long + (.visitLdcInsn (long _value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$FracPM _value) + (doto writer + stack-peek + &&/unwrap-long + (.visitLdcInsn (long _value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$RealPM _value) + (doto writer + stack-peek + &&/unwrap-double + (.visitLdcInsn (double _value)) + (.visitInsn Opcodes/DCMPL) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$CharPM _value) + (doto writer + stack-peek + &&/unwrap-char + (.visitLdcInsn _value) + (.visitJumpInsn Opcodes/IF_ICMPNE $else)) + + (&o/$TextPM _value) + (doto writer + stack-peek + (.visitLdcInsn _value) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFEQ $else)) + + (&o/$TuplePM _idx+) + (|let [[_idx is-tail?] (|case _idx+ + (&/$Left _idx) + (&/T [_idx false]) + + (&/$Right _idx) + (&/T [_idx true]))] + (if (= 0 _idx) + (doto writer + stack-peek + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) + (doto writer + stack-peek + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int _idx)) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" (if is-tail? "product_getRight" "product_getLeft") "([Ljava/lang/Object;I)Ljava/lang/Object;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + ))) + + (&o/$VariantPM _idx+) + (|let [$success (new Label) + $fail (new Label) + [_idx is-last] (|case _idx+ + (&/$Left _idx) + (&/T [_idx false]) + + (&/$Right _idx) + (&/T [_idx true])) + _ (doto writer + stack-peek + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int _idx))) + _ (if is-last + (.visitLdcInsn writer "") + (.visitInsn writer Opcodes/ACONST_NULL))] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFNULL $fail) + (.visitJumpInsn Opcodes/GOTO $success) + (.visitLabel $fail) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else) + (.visitLabel $success) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))) + + (&o/$SeqPM _left-pm _right-pm) + (doto writer + (compile-pattern* bodies stack-depth $else _left-pm) + (compile-pattern* bodies stack-depth $else _right-pm)) + + (&o/$AltPM _left-pm _right-pm) + (|let [$alt-else (new Label)] + (doto writer + (.visitInsn Opcodes/DUP) + (compile-pattern* bodies (inc stack-depth) $alt-else _left-pm) + (.visitLabel $alt-else) + (.visitInsn Opcodes/POP) + (compile-pattern* bodies stack-depth $else _right-pm))) + )) + +(defn ^:private compile-pattern [^MethodVisitor writer bodies pm $end] + (|let [$else (new Label)] + (doto writer + (compile-pattern* bodies 1 $else pm) + (.visitLabel $else) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_fail" "()V") + (.visitInsn Opcodes/ACONST_NULL) + (.visitJumpInsn Opcodes/GOTO $end)))) + +(defn ^:private compile-bodies [^MethodVisitor writer compile bodies-labels ?bodies $end] + (&/map% (fn [label+body] + (|let [[_label _body] label+body] + (|do [:let [_ (.visitLabel writer _label)] + _ (compile _body) + :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] + (return nil)))) + (&/zip2 bodies-labels ?bodies))) + +;; [Resources] +(defn compile-case [compile ?value ?pm ?bodies] + (|do [^MethodVisitor *writer* &/get-writer + :let [$end (new Label) + bodies-labels (&/|map (fn [_] (new Label)) ?bodies)] + _ (compile ?value) + :let [_ (doto *writer* + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) + _ (compile-pattern *writer* bodies-labels ?pm $end)] + _ (compile-bodies *writer* compile bodies-labels ?bodies $end) + :let [_ (.visitLabel *writer* $end)]] + (return nil))) diff --git a/luxc/src/lux/compiler/host.clj b/luxc/src/lux/compiler/host.clj new file mode 100644 index 000000000..9f6d077be --- /dev/null +++ b/luxc/src/lux/compiler/host.clj @@ -0,0 +1,2514 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.host + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [optimizer :as &o] + [host :as &host]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics] + [lux.analyser.base :as &a] + [lux.compiler.base :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor + AnnotationVisitor))) + +;; [Utils] +(def init-method "") + +(let [class+method+sig {"boolean" [(&host-generics/->bytecode-class-name "java.lang.Boolean") "booleanValue" "()Z"] + "byte" [(&host-generics/->bytecode-class-name "java.lang.Byte") "byteValue" "()B"] + "short" [(&host-generics/->bytecode-class-name "java.lang.Short") "shortValue" "()S"] + "int" [(&host-generics/->bytecode-class-name "java.lang.Integer") "intValue" "()I"] + "long" [(&host-generics/->bytecode-class-name "java.lang.Long") "longValue" "()J"] + "float" [(&host-generics/->bytecode-class-name "java.lang.Float") "floatValue" "()F"] + "double" [(&host-generics/->bytecode-class-name "java.lang.Double") "doubleValue" "()D"] + "char" [(&host-generics/->bytecode-class-name "java.lang.Character") "charValue" "()C"]}] + (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name] + (if-let [[class method sig] (get class+method+sig class-name)] + (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST class) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig)) + (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name))))) + +(let [boolean-class "java.lang.Boolean" + byte-class "java.lang.Byte" + short-class "java.lang.Short" + int-class "java.lang.Integer" + long-class "java.lang.Long" + float-class "java.lang.Float" + double-class "java.lang.Double" + char-class "java.lang.Character"] + (defn prepare-return! [^MethodVisitor *writer* *type*] + (|case *type* + (&/$UnitT) + (.visitLdcInsn *writer* &/unit-tag) + + (&/$HostT "boolean" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class))) + + (&/$HostT "byte" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class))) + + (&/$HostT "short" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class))) + + (&/$HostT "int" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class))) + + (&/$HostT "long" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class))) + + (&/$HostT "float" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class))) + + (&/$HostT "double" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class))) + + (&/$HostT "char" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class))) + + (&/$HostT _ _) + nil + + (&/$NamedT ?name ?type) + (prepare-return! *writer* ?type) + + (&/$ExT _) + nil + + _ + (assert false (str 'prepare-return! " " (&type/show-type *type*)))) + *writer*)) + +;; [Resources] +(defn ^:private compile-annotation [writer ann] + (doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->type-signature (:name ann)) true) + (-> (.visit param-name param-value) + (->> (|let [[param-name param-value] param]) + (doseq [param (&/->seq (:params ann))]))) + (.visitEnd)) + nil) + +(defn ^:private compile-field [^ClassWriter writer field] + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (|let [=field (.visitField writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) + ?name + (&host-generics/gclass->simple-signature ?gclass) + (&host-generics/gclass->signature ?gclass) nil)] + (do (&/|map (partial compile-annotation =field) ?anns) + (.visitEnd =field) + nil)) + + (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type) + (|let [=field (.visitField writer + (+ (&host/privacy-modifier->flag =privacy-modifier) + (&host/state-modifier->flag =state-modifier)) + =name + (&host-generics/gclass->simple-signature =type) + (&host-generics/gclass->signature =type) nil)] + (do (&/|map (partial compile-annotation =field) =anns) + (.visitEnd =field) + nil)) + )) + +(defn ^:private compile-method-return [^MethodVisitor writer output] + (|case output + (&/$GenericClass "void" (&/$Nil)) + (.visitInsn writer Opcodes/RETURN) + + (&/$GenericClass "boolean" (&/$Nil)) + (doto writer + &&/unwrap-boolean + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "byte" (&/$Nil)) + (doto writer + &&/unwrap-byte + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "short" (&/$Nil)) + (doto writer + &&/unwrap-short + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "int" (&/$Nil)) + (doto writer + &&/unwrap-int + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "long" (&/$Nil)) + (doto writer + &&/unwrap-long + (.visitInsn Opcodes/LRETURN)) + + (&/$GenericClass "float" (&/$Nil)) + (doto writer + &&/unwrap-float + (.visitInsn Opcodes/FRETURN)) + + (&/$GenericClass "double" (&/$Nil)) + (doto writer + &&/unwrap-double + (.visitInsn Opcodes/DRETURN)) + + (&/$GenericClass "char" (&/$Nil)) + (doto writer + &&/unwrap-char + (.visitInsn Opcodes/IRETURN)) + + _ + (.visitInsn writer Opcodes/ARETURN))) + +(defn ^:private prepare-method-input [idx input ^MethodVisitor method-visitor] + "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))" + (|case input + [_ (&/$GenericClass name params)] + (case name + "boolean" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-boolean + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))]))) + "byte" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-byte + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))]))) + "short" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-short + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))]))) + "int" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-int + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))]))) + "long" (do (doto method-visitor + (.visitVarInsn Opcodes/LLOAD idx) + &&/wrap-long + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)]))) + "float" (do (doto method-visitor + (.visitVarInsn Opcodes/FLOAD idx) + &&/wrap-float + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))]))) + "double" (do (doto method-visitor + (.visitVarInsn Opcodes/DLOAD idx) + &&/wrap-double + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)]))) + "char" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-char + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))]))) + ;; else + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))]))) + + [_ gclass] + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))])) + )) + +(defn ^:private prepare-method-inputs [idx inputs method-visitor] + "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))" + (|case inputs + (&/$Nil) + (return &/$Nil) + + (&/$Cons input inputs*) + (|do [[_ outputs*] (&/fold% (fn [idx+outputs input] + (|do [:let [[_idx _outputs] idx+outputs] + [idx* output] (prepare-method-input _idx input method-visitor)] + (return (&/T [idx* (&/$Cons output _outputs)])))) + (&/T [idx &/$Nil]) + inputs)] + (return (&/list-join (&/|reverse outputs*)))) + )) + +(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def] + (|case method-def + (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (|let [?output (&/$GenericClass "void" (&/|list)) + =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if ?strict Opcodes/ACC_STRICT 0)) + init-method + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [[super-class-name super-class-params] ?super-class + init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str "")) + init-sig (str "(" init-types ")" "V") + _ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + :let [_ (.visitVarInsn =method Opcodes/ALOAD 0)] + _ (->> ?ctor-args (&/|map &/|second) (&/map% compile)) + :let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)] + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$VirtualMethodAnalysis ?name ?privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if =final? Opcodes/ACC_FINAL 0) + (if ?strict Opcodes/ACC_STRICT 0)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$OverridenMethodAnalysis ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC + (if ?strict Opcodes/ACC_STRICT 0)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$StaticMethodAnalysis ?name ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if ?strict Opcodes/ACC_STRICT 0) + Opcodes/ACC_STATIC) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 0 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$AbstractMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_ABSTRACT + (&host/privacy-modifier->flag ?privacy-modifier)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitEnd =method)]] + (return nil)))) + + (&/$NativeMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE + (&host/privacy-modifier->flag ?privacy-modifier)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitEnd =method)]] + (return nil)))) + )) + +(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl] + (|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl) + =method (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + _ (&/|map (partial compile-annotation =method) =anns) + _ (.visitEnd =method)] + nil)) + +(defn ^:private prepare-ctor-arg [^MethodVisitor writer type] + (case type + "boolean" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Boolean")) + &&/unwrap-boolean) + "byte" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Byte")) + &&/unwrap-byte) + "short" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Short")) + &&/unwrap-short) + "int" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Integer")) + &&/unwrap-int) + "long" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Long")) + &&/unwrap-long) + "float" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Float")) + &&/unwrap-float) + "double" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Double")) + &&/unwrap-double) + "char" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Character")) + &&/unwrap-char) + ;; else + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type))))) + +(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object") + -return "V"] + (defn ^:private anon-class--signature [env] + (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" + -return)) + + (defn ^:private add-anon-class- [^ClassWriter class-writer compile class-name super-class env ctor-args] + (|let [[super-class-name super-class-params] super-class + init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))] + (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class--signature env) nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (doto =method + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0))] + _ (&/map% (fn [type+term] + (|let [[type term] type+term] + (|do [_ (compile term) + :let [_ (prepare-ctor-arg =method type)]] + (return nil)))) + ctor-args) + :let [_ (doto =method + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method (str "(" init-types ")" -return)) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [_ (&o/$captured _ ?captured-id ?source)]]) + (doseq [?name+?captured (&/->seq env)]))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) + ) + +(defn ^:private constant-inits [fields] + "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))" + (&/fold &/|++ + &/$Nil + (&/|map (fn [field] + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (&/|list (&/T [?name ?gclass ?value])) + + (&/$VariableFieldSyntax _) + (&/|list) + )) + fields))) + +(declare compile-jvm-putstatic) +(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?inheritance-modifier ?anns ?fields ?methods env ??ctor-args] + (|do [module &/get-module-name + [file-name line column] &/cursor + :let [[?name ?params] class-decl + class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons ?super-class ?interfaces)) + full-name (str module "/" ?name) + super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class)) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER + (&host/inheritance-modifier->flag ?inheritance-modifier)) + full-name (if (= "" class-signature) nil class-signature) super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) + (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =class) ?anns) + _ (&/|map (partial compile-field =class) + ?fields)] + _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods) + _ (|case ??ctor-args + (&/$Some ctor-args) + (add-anon-class- =class compile full-name ?super-class env ctor-args) + + _ + (return nil)) + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (doto =method + (.visitCode))] + _ (&/map% (fn [ftriple] + (|let [[fname fgclass fvalue] ftriple] + (compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass)))) + (constant-inits ?fields)) + :let [_ (doto =method + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))] + (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) + +(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods] + (|do [:let [[interface-name interface-vars] interface-decl] + module &/get-module-name + [file-name _ _] &/cursor + :let [interface-signature (&host-generics/gclass-decl->signature interface-decl ?supers) + =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE) + (str module "/" interface-name) + (if (= "" interface-signature) nil interface-signature) + "java/lang/Object" + (->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) + (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =interface) ?anns) + _ (do (&/|map (partial compile-method-decl =interface) ?methods) + (.visitEnd =interface))]] + (&&/save-class! interface-name (.toByteArray =interface)))) + +(def compile-Function-class + (|do [_ (return nil) + :let [super-class "java/lang/Object" + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER + Opcodes/ACC_ABSTRACT + ;; Opcodes/ACC_INTERFACE + ) + &&/function-class nil super-class (into-array String [])) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil) + (doto (.visitEnd)))) + =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (dotimes [arity* &&/num-apply-variants] + (let [arity (inc arity*)] + (if (= 1 arity) + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil) + (.visitEnd)) + (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil) + (.visitCode) + (-> (.visitVarInsn Opcodes/ALOAD idx) + (->> (dotimes [idx arity]))) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity))) + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitVarInsn Opcodes/ALOAD arity) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))))]] + (&&/save-class! (second (string/split &&/function-class #"/")) + (.toByteArray (doto =class .visitEnd))))) + +(defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class] + (|let [_ (let [$begin (new Label) + $not-rec (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index + (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem + (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPGT $not-rec) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/SWAP) ;; index-last-elem, tuple-size + (.visitInsn Opcodes/ISUB) ;; sub-index + (.visitVarInsn Opcodes/ALOAD 0) ;; sub-index, tuple + (.visitInsn Opcodes/DUP) ;; sub-index, tuple, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; sub-index, tuple, tuple-size + (.visitLdcInsn (int 1)) ;; sub-index, tuple, tuple-size, offset-last-elem + (.visitInsn Opcodes/ISUB) ;; sub-index, tuple, index-last-elem + (.visitInsn Opcodes/AALOAD) ;; sub-index, sub-tuple + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE 0) ;; sub-index + (.visitVarInsn Opcodes/ISTORE 1) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $not-rec) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/POP2) ;; + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index + (.visitInsn Opcodes/AALOAD) ;; elem + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$begin (new Label) + $is-last (new Label) + $must-copy (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index + (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem + (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;; + ;; Must recurse + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/DUP) ;; tuple, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size + (.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem + (.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem + (.visitInsn Opcodes/AALOAD) ;; tuple-tail + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size + (.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1 + (.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size* + (.visitInsn Opcodes/ISUB) ;; tuple-tail, index* + (.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail + (.visitVarInsn Opcodes/ASTORE 0) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $must-copy) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $is-last) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/POP2) ;; + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index + (.visitInsn Opcodes/AALOAD) ;; elem + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$begin (new Label) + $just-return (new Label) + $then (new Label) + $further (new Label) + $not-right (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitVarInsn Opcodes/ILOAD 1) ;; tag + (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum + (.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag' + &&/unwrap-int ;; tag, sum-tag + (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag + (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag + (.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag + (.visitInsn Opcodes/POP2) + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN) + (.visitLabel $then) ;; tag, sum-tag + (.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last? + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last? + (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return) + (.visitJumpInsn Opcodes/GOTO $further) + (.visitLabel $just-return) + (.visitInsn Opcodes/POP2) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 2)) + (.visitInsn Opcodes/AALOAD) + (.visitInsn Opcodes/ARETURN) + (.visitLabel $further) ;; tag, sum-tag + (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum + (.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index? + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last? + (.visitJumpInsn Opcodes/IFNULL $not-right) ;; tag, sum-tag + (.visitInsn Opcodes/ISUB) ;; sub-tag + (.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum + (.visitLdcInsn (int 2)) ;; sub-tag, sum, sub-sum-idx + (.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag + (.visitVarInsn Opcodes/ISTORE 1) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $not-right) ;; tag, sum-tag + (.visitInsn Opcodes/POP2) + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [;; $is-null (new Label) + ] + ;; I commented out some parts because a null-check was + ;; done to ensure variants were never created with null + ;; values (this would interfere later with + ;; pattern-matching). + ;; Since Lux itself doesn't have null values as part of + ;; the language, the burden of ensuring non-nulls was + ;; shifted to library code dealing with host-interop, to + ;; ensure variant-making was as fast as possible. + ;; The null-checking code was left as comments in case I + ;; ever change my mind. + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + ;; (.visitVarInsn Opcodes/ALOAD 2) + ;; (.visitJumpInsn Opcodes/IFNULL $is-null) + (.visitLdcInsn (int 3)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ILOAD 0) + (&&/wrap-int) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 2)) + (.visitVarInsn Opcodes/ALOAD 2) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/ARETURN) + ;; (.visitLabel $is-null) + ;; (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") + ;; (.visitInsn Opcodes/DUP) + ;; (.visitLdcInsn "Can't create variant for null pointer") + ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") + ;; (.visitInsn Opcodes/ATHROW) + (.visitMaxs 0 0) + (.visitEnd)))] + nil)) + +(defn ^:private low-4b [^MethodVisitor =method] + (doto =method + ;; Assume there is a long at the top of the stack... + ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits. + (.visitLdcInsn (int -1)) + (.visitInsn Opcodes/I2L) + ;; Then do a bitwise and. + (.visitInsn Opcodes/LAND) + )) + +(defn ^:private high-4b [^MethodVisitor =method] + (doto =method + ;; Assume there is a long at the top of the stack... + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + )) + +(defn ^:private swap2 [^MethodVisitor =method] + (doto =method + ;; X2, Y2 + (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2 + (.visitInsn Opcodes/POP2) ;; Y2, X2 + )) + +(defn ^:private bit-set-64? [^MethodVisitor =method] + (doto =method + ;; L, I + (.visitLdcInsn (long 1)) ;; L, I, L + (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L + (.visitInsn Opcodes/POP2) ;; L, L, I + (.visitInsn Opcodes/LSHL) ;; L, L + (.visitInsn Opcodes/LAND) ;; L + (.visitLdcInsn (long 0)) ;; L, L + (.visitInsn Opcodes/LCMP) ;; I + )) + +(defn ^:private compile-LuxRT-frac-methods [^ClassWriter =class] + (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_frac" "(JJ)J" nil nil) + ;; Based on: http://stackoverflow.com/a/31629280/6823464 + (.visitCode) + ;; Bottom part + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitVarInsn Opcodes/LLOAD 2) low-4b + (.visitInsn Opcodes/LMUL) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + ;; Middle part + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitVarInsn Opcodes/LLOAD 2) low-4b + (.visitInsn Opcodes/LMUL) + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LMUL) + (.visitInsn Opcodes/LADD) + ;; Join middle and bottom + (.visitInsn Opcodes/LADD) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + ;; Top part + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LMUL) + ;; Join top with rest + (.visitInsn Opcodes/LADD) + ;; Return + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_frac" "(JJ)J" nil nil) + (.visitCode) + ;; Based on: http://stackoverflow.com/a/8510587/6823464 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LDIV) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LSHL) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "frac-to-real" "(J)D" nil nil) + (.visitCode) + ;; Translate high bytes + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitInsn Opcodes/L2D) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + ;; Translate low bytes + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitInsn Opcodes/L2D) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + ;; Combine and return + (.visitInsn Opcodes/DADD) + (.visitInsn Opcodes/DRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-frac" "(D)J" nil nil) + (.visitCode) + ;; Drop any excess + (.visitVarInsn Opcodes/DLOAD 0) + (.visitLdcInsn (double 1.0)) + (.visitInsn Opcodes/DREM) + ;; Shift upper half, but retain remaining decimals + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DMUL) + ;; Make a copy, so the lower half can be extracted + (.visitInsn Opcodes/DUP2) + ;; Get that lower half + (.visitLdcInsn (double 1.0)) + (.visitInsn Opcodes/DREM) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DMUL) + ;; Turn it into a frac + (.visitInsn Opcodes/D2L) + ;; Turn the upper half into frac too + swap2 + (.visitInsn Opcodes/D2L) + ;; Combine both pieces + (.visitInsn Opcodes/LADD) + ;; FINISH + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (let [$start (new Label) + $body (new Label) + $end (new Label) + $zero (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "count_bin_start_0" "(J)I" nil nil) + (.visitCode) + ;; Initialize counter + (.visitLdcInsn (int 0)) ; I + (.visitVarInsn Opcodes/ISTORE 2) ; + ;; Initialize index var + (.visitLdcInsn (int 63)) ; I + ;; Begin loop + (.visitLabel $start) ; I + ;; Make sure we're still on the valid index range + (.visitInsn Opcodes/DUP) ; I, I + (.visitLdcInsn (int -1)) ; I, I, I + (.visitJumpInsn Opcodes/IF_ICMPGT $body) ; I + ;; If not, just return what we've got. + (.visitInsn Opcodes/POP) ; + (.visitVarInsn Opcodes/ILOAD 2) ; I + (.visitJumpInsn Opcodes/GOTO $end) + ;; If so, run the body + (.visitLabel $body) ;; I + (.visitInsn Opcodes/DUP) ;; I, I + (.visitVarInsn Opcodes/LLOAD 0) ;; I, I, L + (.visitInsn Opcodes/DUP2_X1) ;; I, L, I, L + (.visitInsn Opcodes/POP2) ;; I, L, I + bit-set-64? ;; I, I + (.visitJumpInsn Opcodes/IFEQ $zero) ;; I + ;; No more zeroes from now on... + (.visitInsn Opcodes/POP) ;; + (.visitVarInsn Opcodes/ILOAD 2) ;; I + (.visitJumpInsn Opcodes/GOTO $end) + ;; Found another zero... + (.visitLabel $zero) ;; I + ;; Increase counter + (.visitVarInsn Opcodes/ILOAD 2) ;; I, I + (.visitLdcInsn (int 1)) ;; I, I, I + (.visitInsn Opcodes/IADD) ;; I, I + (.visitVarInsn Opcodes/ISTORE 2) ;; I + ;; Increase index, then iterate again... + (.visitLdcInsn (int 1)) ;; I, I + (.visitInsn Opcodes/ISUB) ;; I + (.visitJumpInsn Opcodes/GOTO $start) + ;; Finally, return + (.visitLabel $end) ; I + (.visitInsn Opcodes/IRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$start (new Label) + $can-append (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_text_start_0" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + ;; Initialize accum + (.visitLdcInsn "") ;; S + (.visitVarInsn Opcodes/ASTORE 2) ;; + ;; Initialize comparator + (.visitLdcInsn (long 10)) ;; L + ;; Testing/accum loop + (.visitLabel $start) ;; L + (.visitInsn Opcodes/DUP2) ;; L, L + (.visitVarInsn Opcodes/LLOAD 0) ;; L, L, L + (.visitInsn Opcodes/LCMP) ;; L, I + (.visitJumpInsn Opcodes/IFLT $can-append) ;; L + ;; No more testing. + ;; Throw away the comparator and return accum. + (.visitInsn Opcodes/POP2) ;; + (.visitVarInsn Opcodes/ALOAD 2) ;; S + (.visitJumpInsn Opcodes/GOTO $end) + ;; Can keep accumulating + (.visitLabel $can-append) ;; L + ;; Add one more 0 to accum + (.visitVarInsn Opcodes/ALOAD 2) ;; L, S + (.visitLdcInsn "0") ;; L, S, S + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") ;; L, S + (.visitVarInsn Opcodes/ASTORE 2) ;; L + ;; Update comparator and re-iterate + (.visitLdcInsn (long 10)) ;; L, L + (.visitInsn Opcodes/LMUL) ;; L + (.visitJumpInsn Opcodes/GOTO $start) + (.visitLabel $end) ;; S + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$is-zero (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_frac" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFEQ $is-zero) + ;; IF =/= 0 + ;; Generate leading 0s + (.visitLdcInsn (long 1)) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_bin_start_0" "(J)I") + (.visitInsn Opcodes/LSHL) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_text_start_0" "(J)Ljava/lang/String;") + ;; Convert to number text + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toUnsignedString" "(J)Ljava/lang/String;") + ;; Remove unnecessary trailing zeroes + (.visitLdcInsn "0*$") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;") + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + ;; Join leading 0s with number text + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + ;; FINISH + (.visitJumpInsn Opcodes/GOTO $end) + ;; IF == 0 + (.visitLabel $is-zero) + (.visitLdcInsn ".0") + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$end (new Label) + ;; $then (new Label) + $else (new Label) + $from (new Label) + $to (new Label) + $handler (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_frac" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) + (.visitCode) + ;; Check prefix + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn ".") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z") + (.visitJumpInsn Opcodes/IFEQ $else) + ;; Remove prefix + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/DUP) + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "read_frac_text" "(Ljava/lang/String;)J") + (.visitLabel $to) + (.visitInsn Opcodes/DUP2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_bin_start_0" "(J)I") + (.visitInsn Opcodes/LSHL) + (.visitInsn Opcodes/DUP2_X1) + (.visitInsn Opcodes/POP2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_leading_zeroes" "(Ljava/lang/String;)J") + (.visitInsn Opcodes/L2D) + (.visitLdcInsn (double 10.0)) + swap2 + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "pow" "(DD)D") + (.visitInsn Opcodes/D2L) + (.visitInsn Opcodes/LDIV) + ;; (.visitJumpInsn Opcodes/GOTO $then) + ;; (.visitLabel $then) + (&&/wrap-long) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $handler) + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Exception"])) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) + (.visitJumpInsn Opcodes/GOTO $end) + ;; Doesn't start with necessary prefix. + (.visitLabel $else) + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 0 (to-array [])) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitLabel $end) + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [string-bcn (&host-generics/->bytecode-class-name "java.lang.String") + $valid (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "count_leading_zeroes" "(Ljava/lang/String;)J" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) ;; S + (.visitLdcInsn "^0*") ;; S, S + (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "split" "(Ljava/lang/String;)[Ljava/lang/String;") ;; [S + (.visitInsn Opcodes/DUP) ;; [S, [S + (.visitInsn Opcodes/ARRAYLENGTH) ;; [S, I + (.visitLdcInsn (int 2)) ;; [S, I, I + (.visitJumpInsn Opcodes/IF_ICMPEQ $valid) ;; [S + ;; Invalid... + (.visitInsn Opcodes/POP) ;; + (.visitLdcInsn (long 0)) ;; J + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $valid) ;; [S + ;; Valid... + (.visitLdcInsn (int 1)) ;; [S, I + (.visitInsn Opcodes/AALOAD) ;; S + (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "length" "()I") ;; I + (.visitVarInsn Opcodes/ALOAD 0) ;; I, S + (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "length" "()I") ;; I, I + (.visitInsn Opcodes/SWAP) ;; I, I + (.visitInsn Opcodes/ISUB) ;; I + (.visitInsn Opcodes/I2L) ;; J + (.visitLabel $end) ;; J + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$only-zeroes (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "read_frac_text" "(Ljava/lang/String;)J" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn "0*$") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL + (&host-generics/->bytecode-class-name "java.lang.String") + "split" "(Ljava/lang/String;)[Ljava/lang/String;") + (.visitInsn Opcodes/DUP) + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitJumpInsn Opcodes/IFEQ $only-zeroes) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $only-zeroes) + (.visitInsn Opcodes/POP) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J") + (.visitLabel $end) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ] + nil)) + +(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + (defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class] + (|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677 + _ (let [$from (new Label) + $to (new Label) + $handler (new Label) + + $good-start (new Label) + $short-enough (new Label) + $bad-digit (new Label) + $out-of-bounds (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from) + ;; Remove the + at the beginning... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitLdcInsn (int 0)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitLdcInsn "+") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFNE $good-start) + ;; Doesn't start with + + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Starts with + + (.visitLabel $good-start) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix... + ;; Begin parsing processs + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 18)) + (.visitJumpInsn Opcodes/IF_ICMPLE $short-enough) + ;; Too long + ;; Get prefix... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") + (.visitInsn Opcodes/DUP2) ;; Clone prefix, for later... + ;; Get last digit... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") + (.visitLdcInsn (int 10)) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I") + ;; Test last digit... + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFLT $bad-digit) + ;; Good digit... + ;; Stack: prefix::L, prefix::L, last-digit::I + (.visitInsn Opcodes/I2L) + ;; Build the result... + swap2 + (.visitLdcInsn (long 10)) + (.visitInsn Opcodes/LMUL) + (.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L + (.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L + swap2 ;; Stack: result::L, result::L, prefix::L + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $out-of-bounds) + ;; Within bounds + ;; Stack: result::L + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Out of bounds + (.visitLabel $out-of-bounds) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Bad digit... + (.visitLabel $bad-digit) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; 18 chars or less + (.visitLabel $short-enough) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) + (.visitLabel $handler) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172 + _ (let [$too-big (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitLdcInsn "+") + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLT $too-big) + ;; then + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + ;; else + (.visitLabel $too-big) + ;; Set up parts of the number string... + ;; First digits + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/LUSHR) + (.visitLdcInsn (long 5)) + (.visitInsn Opcodes/LDIV) ;; quot + ;; Last digit + (.visitInsn Opcodes/DUP2) + (.visitLdcInsn (long 10)) + (.visitInsn Opcodes/LMUL) + (.visitVarInsn Opcodes/LLOAD 0) + swap2 + (.visitInsn Opcodes/LSUB) ;; quot, rem + ;; Conversion to string... + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem* + (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem* + (.visitInsn Opcodes/POP) ;; rem*, quot + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot* + (.visitInsn Opcodes/SWAP) ;; quot*, rem* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 + _ (let [$simple-case (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFGE $simple-case) + ;; else + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitLdcInsn (int 32)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LSHL) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitInsn Opcodes/ARETURN) + ;; then + (.visitLabel $simple-case) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") + (.visitInsn Opcodes/LADD) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") + (.visitInsn Opcodes/LADD) + (.visitInsn Opcodes/LCMP) + (.visitInsn Opcodes/IRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 + _ (let [$case-1 (new Label) + $0 (new Label) + $case-2 (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil) + (.visitCode) + ;; Test #1 + (.visitVarInsn Opcodes/LLOAD 2) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLT $case-1) + ;; Test #2 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFGT $case-2) + ;; Case #3 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") + (.visitInsn Opcodes/LRETURN) + ;; Case #2 + (.visitLabel $case-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitInsn Opcodes/LDIV) + (.visitInsn Opcodes/LRETURN) + ;; Case #1 + (.visitLabel $case-1) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $0) + ;; 1 + (.visitLdcInsn (long 1)) + (.visitInsn Opcodes/LRETURN) + ;; 0 + (.visitLabel $0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 + _ (let [$test-2 (new Label) + $case-2 (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil) + (.visitCode) + ;; Test #1 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLE $test-2) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLE $test-2) + ;; Case #1 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitInsn Opcodes/LREM) + (.visitInsn Opcodes/LRETURN) + ;; Test #2 + (.visitLabel $test-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $case-2) + ;; Case #3 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") + (.visitInsn Opcodes/LRETURN) + ;; Case #2 + (.visitLabel $case-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitInsn Opcodes/LRETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitMaxs 0 0) + (.visitEnd)))] + nil))) + +(defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class] + (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil) + (.visitCode) + (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn "Invalid expression for pattern-matching.") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") + (.visitInsn Opcodes/ATHROW) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (int 2)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))] + nil)) + +(def compile-LuxRT-class + (|do [_ (return nil) + :let [full-name &&/lux-utils-class + super-class (&host-generics/->bytecode-class-name "java.lang.Object") + tag-sig (&host-generics/->type-signature "java.lang.String") + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + full-name nil super-class (into-array String []))) + =unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag) + (.visitEnd)) + =init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") + (.visitLdcInsn "LOG: ") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V") + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; I + (.visitInsn Opcodes/ACONST_NULL) ;; I? + (.visitLdcInsn &/unit-tag) ;; I?U + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I + (.visitInsn Opcodes/ACONST_NULL) ;; I? + (.visitVarInsn Opcodes/ALOAD 0) ;; I?O + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn ",|_") + (.visitLdcInsn "") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto =class + (compile-LuxRT-pm-methods) + (compile-LuxRT-adt-methods) + (compile-LuxRT-nat-methods) + (compile-LuxRT-frac-methods))]] + (&&/save-class! (second (string/split &&/lux-utils-class #"/")) + (.toByteArray (doto =class .visitEnd))))) + +(defn ^:private compile-jvm-try [compile ?values special-args] + (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + :let [$from (new Label) + $to (new Label) + $handler (new Label) + $end (new Label)] + :let [_ (doto *writer* + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from))] + _ (compile ?body) + :let [_ (doto *writer* + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $to) + (.visitLabel $handler))] + _ (compile ?catch) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] + :let [_ (.visitLabel *writer* $end)]] + (return nil))) + +(do-template [ ] + (defn [compile _?value special-args] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW (&host-generics/->bytecode-class-name )) + (.visitInsn Opcodes/DUP))] + _ (compile ?value) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name )) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name ) ) + (.visitInsn ) + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name ) init-method ))]] + (return nil))) + + ^:private compile-jvm-d2f Opcodes/D2F "java.lang.Double" "doubleValue" "()D" "java.lang.Float" "(F)V" + ^:private compile-jvm-d2i Opcodes/D2I "java.lang.Double" "doubleValue" "()D" "java.lang.Integer" "(I)V" + ^:private compile-jvm-d2l Opcodes/D2L "java.lang.Double" "doubleValue" "()D" "java.lang.Long" "(J)V" + + ^:private compile-jvm-f2d Opcodes/F2D "java.lang.Float" "floatValue" "()F" "java.lang.Double" "(D)V" + ^:private compile-jvm-f2i Opcodes/F2I "java.lang.Float" "floatValue" "()F" "java.lang.Integer" "(I)V" + ^:private compile-jvm-f2l Opcodes/F2L "java.lang.Float" "floatValue" "()F" "java.lang.Long" "(J)V" + + ^:private compile-jvm-i2b Opcodes/I2B "java.lang.Integer" "intValue" "()I" "java.lang.Byte" "(B)V" + ^:private compile-jvm-i2c Opcodes/I2C "java.lang.Integer" "intValue" "()I" "java.lang.Character" "(C)V" + ^:private compile-jvm-i2d Opcodes/I2D "java.lang.Integer" "intValue" "()I" "java.lang.Double" "(D)V" + ^:private compile-jvm-i2f Opcodes/I2F "java.lang.Integer" "intValue" "()I" "java.lang.Float" "(F)V" + ^:private compile-jvm-i2l Opcodes/I2L "java.lang.Integer" "intValue" "()I" "java.lang.Long" "(J)V" + ^:private compile-jvm-i2s Opcodes/I2S "java.lang.Integer" "intValue" "()I" "java.lang.Short" "(S)V" + + ^:private compile-jvm-l2d Opcodes/L2D "java.lang.Long" "longValue" "()J" "java.lang.Double" "(D)V" + ^:private compile-jvm-l2f Opcodes/L2F "java.lang.Long" "longValue" "()J" "java.lang.Float" "(F)V" + ^:private compile-jvm-l2i Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Integer" "(I)V" + ^:private compile-jvm-l2s Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Short" "(S)V" + ^:private compile-jvm-l2b Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Byte" "(B)V" + + ^:private compile-jvm-c2b Opcodes/I2B "java.lang.Character" "charValue" "()C" "java.lang.Byte" "(B)V" + ^:private compile-jvm-c2s Opcodes/I2S "java.lang.Character" "charValue" "()C" "java.lang.Short" "(S)V" + ^:private compile-jvm-c2i Opcodes/NOP "java.lang.Character" "charValue" "()C" "java.lang.Integer" "(I)V" + ^:private compile-jvm-c2l Opcodes/I2L "java.lang.Character" "charValue" "()C" "java.lang.Long" "(J)V" + + ^:private compile-jvm-s2l Opcodes/I2L "java.lang.Short" "shortValue" "()S" "java.lang.Long" "(J)V" + + ^:private compile-jvm-b2l Opcodes/I2L "java.lang.Byte" "byteValue" "()B" "java.lang.Long" "(J)V" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW (&host-generics/->bytecode-class-name )) + (.visitInsn Opcodes/DUP))] + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name )) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name ) ))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name )) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name ) ))] + :let [_ (doto *writer* + (.visitInsn ) + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name ) init-method ))]] + (return nil))) + + ^:private compile-jvm-iand Opcodes/IAND "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + ^:private compile-jvm-ior Opcodes/IOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + ^:private compile-jvm-ixor Opcodes/IXOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + ^:private compile-jvm-ishl Opcodes/ISHL "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + ^:private compile-jvm-ishr Opcodes/ISHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + ^:private compile-jvm-iushr Opcodes/IUSHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + + ^:private compile-jvm-land Opcodes/LAND "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" + ^:private compile-jvm-lor Opcodes/LOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" + ^:private compile-jvm-lxor Opcodes/LXOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" + ^:private compile-jvm-lshl Opcodes/LSHL "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" + ^:private compile-jvm-lshr Opcodes/LSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" + ^:private compile-jvm-lushr Opcodes/LUSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name )] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) + _ (doto *writer* + (.visitInsn ) + ())]] + (return nil))) + + ^:private compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" &&/wrap-int + ^:private compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" &&/wrap-int + ^:private compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" &&/wrap-int + ^:private compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" &&/wrap-int + ^:private compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" &&/wrap-int + + ^:private compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" &&/wrap-long + + ^:private compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" &&/wrap-float + ^:private compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" &&/wrap-float + ^:private compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" &&/wrap-float + ^:private compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" &&/wrap-float + ^:private compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" &&/wrap-float + + ^:private compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" &&/wrap-double + ^:private compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" &&/wrap-double + ^:private compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" &&/wrap-double + ^:private compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" &&/wrap-double + ^:private compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" &&/wrap-double + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name )] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-jvm-ieq Opcodes/IF_ICMPEQ "java.lang.Integer" "intValue" "()I" + ^:private compile-jvm-ilt Opcodes/IF_ICMPLT "java.lang.Integer" "intValue" "()I" + ^:private compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I" + + ^:private compile-jvm-ceq Opcodes/IF_ICMPEQ "java.lang.Character" "charValue" "()C" + ^:private compile-jvm-clt Opcodes/IF_ICMPLT "java.lang.Character" "charValue" "()C" + ^:private compile-jvm-cgt Opcodes/IF_ICMPGT "java.lang.Character" "charValue" "()C" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name )] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn ) + (.visitLdcInsn (int )) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" + ^:private compile-jvm-llt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" + ^:private compile-jvm-lgt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J" + + ^:private compile-jvm-feq Opcodes/FCMPG 0 "java.lang.Float" "floatValue" "()F" + ^:private compile-jvm-flt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F" + ^:private compile-jvm-fgt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F" + + ^:private compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()D" + ^:private compile-jvm-dlt Opcodes/DCMPG -1 "java.lang.Double" "doubleValue" "()D" + ^:private compile-jvm-dgt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()D" + ) + +(do-template [ ] + (do (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?length) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY )]] + (return nil))) + + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn ) + )]] + (return nil))) + + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (doto *writer* + + (.visitInsn ))]] + (return nil))) + ) + + Opcodes/T_BOOLEAN "[Z" ^:private compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean + Opcodes/T_BYTE "[B" ^:private compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte + Opcodes/T_SHORT "[S" ^:private compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short + Opcodes/T_INT "[I" ^:private compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int + Opcodes/T_LONG "[J" ^:private compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long + Opcodes/T_FLOAT "[F" ^:private compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float + Opcodes/T_DOUBLE "[D" ^:private compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double + Opcodes/T_CHAR "[C" ^:private compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char + ) + +(defn ^:private compile-jvm-anewarray [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values + (&/$Cons ?gclass (&/$Cons type-env (&/$Nil))) special-args] + ^MethodVisitor *writer* &/get-writer + _ (compile ?length) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]] + (return nil))) + +(defn ^:private compile-jvm-aaload [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] + (return nil))) + +(defn ^:private compile-jvm-aastore [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return nil))) + +(defn ^:private compile-jvm-arraylength [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + :let [_ (doto *writer* + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(defn ^:private compile-jvm-null [compile ?values special-args] + (|do [:let [;; (&/$Nil) ?values + (&/$Nil) special-args] + ^MethodVisitor *writer* &/get-writer + :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] + (return nil))) + +(defn ^:private compile-jvm-null? [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?object) + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn Opcodes/IFNULL $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + +(defn compile-jvm-synchronized [compile ?values special-args] + (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?monitor) + :let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitInsn Opcodes/MONITORENTER))] + _ (compile ?expr) + :let [_ (doto *writer* + (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/MONITOREXIT))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?monitor (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?monitor) + :let [_ (doto *writer* + (.visitInsn ) + (.visitInsn Opcodes/ACONST_NULL))]] + (return nil))) + + ^:private compile-jvm-monitorenter Opcodes/MONITORENTER + ^:private compile-jvm-monitorexit Opcodes/MONITOREXIT + ) + +(defn ^:private compile-jvm-throw [compile ?values special-args] + (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?ex) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) + +(defn ^:private compile-jvm-getstatic [compile ?values special-args] + (|do [:let [;; (&/$Nil) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] + ^MethodVisitor *writer* &/get-writer + =output-type (&host/->java-sig ?output-type) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type) + (prepare-return! ?output-type))]] + (return nil))) + +(defn ^:private compile-jvm-getfield [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Nil)) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] + :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + _ (compile ?object) + =output-type (&host/->java-sig ?output-type) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST class*) + (.visitFieldInsn Opcodes/GETFIELD class* ?field =output-type) + (prepare-return! ?output-type))]] + (return nil))) + +(defn ^:private compile-jvm-putstatic [compile ?values special-args] + (|do [:let [(&/$Cons ?value (&/$Nil)) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Nil)))) special-args] + ^MethodVisitor *writer* &/get-writer + _ (compile ?value) + :let [=input-sig (&host-type/gclass->sig input-gclass) + _ (doto *writer* + (prepare-arg! (&host-generics/gclass->class-name input-gclass)) + (.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig) + (.visitInsn Opcodes/ACONST_NULL))]] + (return nil))) + +(defn ^:private compile-jvm-putfield [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?value (&/$Nil))) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Cons ?input-type (&/$Nil))))) special-args] + :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + _ (compile ?object) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] + _ (compile ?value) + =input-sig (&host/->java-sig ?input-type) + :let [_ (doto *writer* + (prepare-arg! (&host-generics/gclass->class-name input-gclass)) + (.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig) + (.visitInsn Opcodes/ACONST_NULL))]] + (return nil))) + +(defn ^:private compile-jvm-invokestatic [compile ?values special-args] + (|do [:let [?args ?values + (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig) + (prepare-return! ?output-type))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?object ?args) ?values + (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] + :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] + _ (compile ?object) + :let [_ (when (not= "" ?method) + (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn ?class* ?method method-sig) + (prepare-return! ?output-type))]] + (return nil))) + + ^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL + ^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE + ^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL + ) + +(defn ^:private compile-jvm-new [compile ?values special-args] + (|do [:let [?args ?values + (&/$Cons ?class (&/$Cons ?classes (&/$Nil))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V") + class* (&host-generics/->bytecode-class-name ?class) + _ (doto *writer* + (.visitTypeInsn Opcodes/NEW class*) + (.visitInsn Opcodes/DUP))] + _ (&/map% (fn [class-name+arg] + (|do [:let [[class-name arg] class-name+arg] + ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + (&/zip2 ?classes ?args)) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESPECIAL class* "" init-sig))]] + (return nil))) + +(defn ^:private compile-jvm-try [compile ?values special-args] + (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + :let [$from (new Label) + $to (new Label) + $handler (new Label) + $end (new Label)] + :let [_ (doto *writer* + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from))] + _ (compile ?body) + :let [_ (doto *writer* + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $to) + (.visitLabel $handler))] + _ (compile ?catch) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] + :let [_ (.visitLabel *writer* $end)]] + (return nil))) + +(defn ^:private compile-jvm-load-class [compile ?values special-args] + (|do [:let [(&/$Cons _class-name (&/$Cons ?output-type (&/$Nil))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitLdcInsn _class-name) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Class" "forName" "(Ljava/lang/String;)Ljava/lang/Class;") + (prepare-return! ?output-type))]] + (return nil))) + +(defn ^:private compile-jvm-instanceof [compile ?values special-args] + (|do [:let [(&/$Cons object (&/$Nil)) ?values + (&/$Cons class (&/$Nil)) special-args] + :let [class* (&host-generics/->bytecode-class-name class)] + ^MethodVisitor *writer* &/get-writer + _ (compile object) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/INSTANCEOF class*) + (&&/wrap-boolean))]] + (return nil))) + +(defn ^:private compile-array-get [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)] + :let [$is-null (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFNULL $is-null) + (.visitLdcInsn (int 1)) + (.visitLdcInsn "") + (.visitInsn Opcodes/DUP2_X1) ;; I?2I? + (.visitInsn Opcodes/POP2) ;; I?2 + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $is-null) + (.visitInsn Opcodes/POP) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/ACONST_NULL) + (.visitLdcInsn &/unit-tag) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitLabel $end))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + _ (compile ?mask) + :let [_ (&&/unwrap-long *writer*)] + :let [_ (doto *writer* + (.visitInsn ) + &&/wrap-long)]] + (return nil))) + + ^:private compile-bit-and Opcodes/LAND + ^:private compile-bit-or Opcodes/LOR + ^:private compile-bit-xor Opcodes/LXOR + ) + +(defn ^:private compile-bit-count [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + _ (compile ?shift) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn ) + &&/wrap-long)]] + (return nil))) + + ^:private compile-bit-shift-left Opcodes/LSHL + ^:private compile-bit-shift-right Opcodes/LSHR + ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR + ) + +(defn ^:private compile-lux-== [compile ?values special-args] + (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?left) + _ (compile ?right) + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn Opcodes/IF_ACMPEQ $then) + ;; else + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") + (.visitLabel $end))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name )] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) + _ (doto *writer* + (.visitInsn ) + ())]] + (return nil))) + + ^:private compile-nat-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-nat-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-nat-mul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long + + ^:private compile-frac-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-frac-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-frac-rem Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-frac-scale Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J")) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") + (&&/wrap-long))]] + (return nil))) + + ^:private compile-nat-div "div_nat" + ^:private compile-nat-rem "rem_nat" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J")) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitLdcInsn (int )) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-nat-eq 0 + + ^:private compile-frac-eq 0 + ^:private compile-frac-lt -1 + ) + +(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + (defn ^:private compile-nat-lt [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J")) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitLdcInsn (int -1)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil)))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Nil) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + + )]] + (return nil))) + + ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long + ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long + + ^:private compile-frac-min-value (.visitLdcInsn 0) &&/wrap-long + ^:private compile-frac-max-value (.visitLdcInsn -1) &&/wrap-long + ) + +(do-template [ ] + (do (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] + (return nil))) + + (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] + (return nil))))) + + ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" + ^:private compile-frac-encode "encode_frac" ^:private compile-frac-decode "decode_frac" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + &&/unwrap-long)] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + &&/unwrap-long)] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") + &&/wrap-long)]] + (return nil))) + + ^:private compile-frac-mul "mul_frac" + ^:private compile-frac-div "div_frac" + ) + +(do-template [ ] + (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) + )]] + (return nil)))) + + ^:private compile-frac-to-real "java.lang.Long" "frac-to-real" "(J)D" &&/unwrap-long &&/wrap-double + ^:private compile-real-to-frac "java.lang.Double" "real-to-frac" "(D)J" &&/unwrap-double &&/wrap-long + ) + +(let [widen (fn [^MethodVisitor *writer*] + (doto *writer* + (.visitInsn Opcodes/I2L))) + shrink (fn [^MethodVisitor *writer*] + (doto *writer* + (.visitInsn Opcodes/L2I) + (.visitInsn Opcodes/I2C)))] + (do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + + + )]] + (return nil))) + + ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink + ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen + )) + +(do-template [] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x)] + (return nil))) + + ^:private compile-nat-to-int + ^:private compile-int-to-nat + ) + +(defn compile-host [compile proc-category proc-name ?values special-args] + (case proc-category + "lux" + (case proc-name + "==" (compile-lux-== compile ?values special-args)) + + "bit" + (case proc-name + "count" (compile-bit-count compile ?values special-args) + "and" (compile-bit-and compile ?values special-args) + "or" (compile-bit-or compile ?values special-args) + "xor" (compile-bit-xor compile ?values special-args) + "shift-left" (compile-bit-shift-left compile ?values special-args) + "shift-right" (compile-bit-shift-right compile ?values special-args) + "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) + + "array" + (case proc-name + "get" (compile-array-get compile ?values special-args)) + + "nat" + (case proc-name + "+" (compile-nat-add compile ?values special-args) + "-" (compile-nat-sub compile ?values special-args) + "*" (compile-nat-mul compile ?values special-args) + "/" (compile-nat-div compile ?values special-args) + "%" (compile-nat-rem compile ?values special-args) + "=" (compile-nat-eq compile ?values special-args) + "<" (compile-nat-lt compile ?values special-args) + "encode" (compile-nat-encode compile ?values special-args) + "decode" (compile-nat-decode compile ?values special-args) + "max-value" (compile-nat-max-value compile ?values special-args) + "min-value" (compile-nat-min-value compile ?values special-args) + "to-int" (compile-nat-to-int compile ?values special-args) + "to-char" (compile-nat-to-char compile ?values special-args) + ) + + "frac" + (case proc-name + "+" (compile-frac-add compile ?values special-args) + "-" (compile-frac-sub compile ?values special-args) + "*" (compile-frac-mul compile ?values special-args) + "/" (compile-frac-div compile ?values special-args) + "%" (compile-frac-rem compile ?values special-args) + "=" (compile-frac-eq compile ?values special-args) + "<" (compile-frac-lt compile ?values special-args) + "encode" (compile-frac-encode compile ?values special-args) + "decode" (compile-frac-decode compile ?values special-args) + "max-value" (compile-frac-max-value compile ?values special-args) + "min-value" (compile-frac-min-value compile ?values special-args) + "to-real" (compile-frac-to-real compile ?values special-args) + "scale" (compile-frac-scale compile ?values special-args) + ) + + "int" + (case proc-name + "to-nat" (compile-int-to-nat compile ?values special-args) + ) + + "real" + (case proc-name + "to-frac" (compile-real-to-frac compile ?values special-args) + ) + + "char" + (case proc-name + "to-nat" (compile-char-to-nat compile ?values special-args) + ) + + "jvm" + (case proc-name + "synchronized" (compile-jvm-synchronized compile ?values special-args) + "load-class" (compile-jvm-load-class compile ?values special-args) + "instanceof" (compile-jvm-instanceof compile ?values special-args) + "try" (compile-jvm-try compile ?values special-args) + "new" (compile-jvm-new compile ?values special-args) + "invokestatic" (compile-jvm-invokestatic compile ?values special-args) + "invokeinterface" (compile-jvm-invokeinterface compile ?values special-args) + "invokevirtual" (compile-jvm-invokevirtual compile ?values special-args) + "invokespecial" (compile-jvm-invokespecial compile ?values special-args) + "getstatic" (compile-jvm-getstatic compile ?values special-args) + "getfield" (compile-jvm-getfield compile ?values special-args) + "putstatic" (compile-jvm-putstatic compile ?values special-args) + "putfield" (compile-jvm-putfield compile ?values special-args) + "throw" (compile-jvm-throw compile ?values special-args) + "monitorenter" (compile-jvm-monitorenter compile ?values special-args) + "monitorexit" (compile-jvm-monitorexit compile ?values special-args) + "null?" (compile-jvm-null? compile ?values special-args) + "null" (compile-jvm-null compile ?values special-args) + "anewarray" (compile-jvm-anewarray compile ?values special-args) + "aaload" (compile-jvm-aaload compile ?values special-args) + "aastore" (compile-jvm-aastore compile ?values special-args) + "arraylength" (compile-jvm-arraylength compile ?values special-args) + "znewarray" (compile-jvm-znewarray compile ?values special-args) + "bnewarray" (compile-jvm-bnewarray compile ?values special-args) + "snewarray" (compile-jvm-snewarray compile ?values special-args) + "inewarray" (compile-jvm-inewarray compile ?values special-args) + "lnewarray" (compile-jvm-lnewarray compile ?values special-args) + "fnewarray" (compile-jvm-fnewarray compile ?values special-args) + "dnewarray" (compile-jvm-dnewarray compile ?values special-args) + "cnewarray" (compile-jvm-cnewarray compile ?values special-args) + "iadd" (compile-jvm-iadd compile ?values special-args) + "isub" (compile-jvm-isub compile ?values special-args) + "imul" (compile-jvm-imul compile ?values special-args) + "idiv" (compile-jvm-idiv compile ?values special-args) + "irem" (compile-jvm-irem compile ?values special-args) + "ieq" (compile-jvm-ieq compile ?values special-args) + "ilt" (compile-jvm-ilt compile ?values special-args) + "igt" (compile-jvm-igt compile ?values special-args) + "ceq" (compile-jvm-ceq compile ?values special-args) + "clt" (compile-jvm-clt compile ?values special-args) + "cgt" (compile-jvm-cgt compile ?values special-args) + "ladd" (compile-jvm-ladd compile ?values special-args) + "lsub" (compile-jvm-lsub compile ?values special-args) + "lmul" (compile-jvm-lmul compile ?values special-args) + "ldiv" (compile-jvm-ldiv compile ?values special-args) + "lrem" (compile-jvm-lrem compile ?values special-args) + "leq" (compile-jvm-leq compile ?values special-args) + "llt" (compile-jvm-llt compile ?values special-args) + "lgt" (compile-jvm-lgt compile ?values special-args) + "fadd" (compile-jvm-fadd compile ?values special-args) + "fsub" (compile-jvm-fsub compile ?values special-args) + "fmul" (compile-jvm-fmul compile ?values special-args) + "fdiv" (compile-jvm-fdiv compile ?values special-args) + "frem" (compile-jvm-frem compile ?values special-args) + "feq" (compile-jvm-feq compile ?values special-args) + "flt" (compile-jvm-flt compile ?values special-args) + "fgt" (compile-jvm-fgt compile ?values special-args) + "dadd" (compile-jvm-dadd compile ?values special-args) + "dsub" (compile-jvm-dsub compile ?values special-args) + "dmul" (compile-jvm-dmul compile ?values special-args) + "ddiv" (compile-jvm-ddiv compile ?values special-args) + "drem" (compile-jvm-drem compile ?values special-args) + "deq" (compile-jvm-deq compile ?values special-args) + "dlt" (compile-jvm-dlt compile ?values special-args) + "dgt" (compile-jvm-dgt compile ?values special-args) + "iand" (compile-jvm-iand compile ?values special-args) + "ior" (compile-jvm-ior compile ?values special-args) + "ixor" (compile-jvm-ixor compile ?values special-args) + "ishl" (compile-jvm-ishl compile ?values special-args) + "ishr" (compile-jvm-ishr compile ?values special-args) + "iushr" (compile-jvm-iushr compile ?values special-args) + "land" (compile-jvm-land compile ?values special-args) + "lor" (compile-jvm-lor compile ?values special-args) + "lxor" (compile-jvm-lxor compile ?values special-args) + "lshl" (compile-jvm-lshl compile ?values special-args) + "lshr" (compile-jvm-lshr compile ?values special-args) + "lushr" (compile-jvm-lushr compile ?values special-args) + "d2f" (compile-jvm-d2f compile ?values special-args) + "d2i" (compile-jvm-d2i compile ?values special-args) + "d2l" (compile-jvm-d2l compile ?values special-args) + "f2d" (compile-jvm-f2d compile ?values special-args) + "f2i" (compile-jvm-f2i compile ?values special-args) + "f2l" (compile-jvm-f2l compile ?values special-args) + "i2b" (compile-jvm-i2b compile ?values special-args) + "i2c" (compile-jvm-i2c compile ?values special-args) + "i2d" (compile-jvm-i2d compile ?values special-args) + "i2f" (compile-jvm-i2f compile ?values special-args) + "i2l" (compile-jvm-i2l compile ?values special-args) + "i2s" (compile-jvm-i2s compile ?values special-args) + "l2d" (compile-jvm-l2d compile ?values special-args) + "l2f" (compile-jvm-l2f compile ?values special-args) + "l2i" (compile-jvm-l2i compile ?values special-args) + "l2s" (compile-jvm-l2s compile ?values special-args) + "l2b" (compile-jvm-l2b compile ?values special-args) + "c2b" (compile-jvm-c2b compile ?values special-args) + "c2s" (compile-jvm-c2s compile ?values special-args) + "c2i" (compile-jvm-c2i compile ?values special-args) + "c2l" (compile-jvm-c2l compile ?values special-args) + "s2l" (compile-jvm-s2l compile ?values special-args) + "b2l" (compile-jvm-b2l compile ?values special-args) + ;; else + (fail (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name]))) + + ;; else + (fail (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/io.clj b/luxc/src/lux/compiler/io.clj new file mode 100644 index 000000000..ecb2066cd --- /dev/null +++ b/luxc/src/lux/compiler/io.clj @@ -0,0 +1,36 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.io + (:require (lux [base :as & :refer [|case |let |do return* return fail fail*]]) + (lux.compiler [base :as &&]) + [lux.lib.loader :as &lib])) + +;; [Utils] +(def ^:private !libs (atom nil)) + +(defn ^:private libs-imported? [] + (not (nil? @!libs))) + +(defn ^:private init-libs! [] + (reset! !libs (&lib/load))) + +;; [Resources] +(defn read-file [source-dirs ^String file-name] + (|case (&/|some (fn [source-dir] + (let [file (new java.io.File (str source-dir "/" file-name))] + (if (.exists file) + (&/$Some file) + &/$None))) + source-dirs) + (&/$Some file) + (return (slurp file)) + + (&/$None) + (do (when (not (libs-imported?)) + (init-libs!)) + (if-let [code (get @!libs file-name)] + (return code) + (fail (str "[I/O Error] File doesn't exist: " file-name)))))) diff --git a/luxc/src/lux/compiler/lambda.clj b/luxc/src/lux/compiler/lambda.clj new file mode 100644 index 000000000..c0096523f --- /dev/null +++ b/luxc/src/lux/compiler/lambda.clj @@ -0,0 +1,286 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.lambda + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |case |let]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + [lux.host.generics :as &host-generics] + [lux.analyser.base :as &a] + (lux.compiler [base :as &&])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Utils] +(def ^:private field-sig (&host-generics/->type-signature "java.lang.Object")) +(def ^:private lambda-return-sig (&host-generics/->type-signature "java.lang.Object")) +(def ^:private -return "V") + +(defn ^:private ^String reset-signature [function-class] + (str "()" (&host-generics/->type-signature function-class))) + +(defn ^:private ^MethodVisitor get-num-partials! [^MethodVisitor method-writer] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD &&/function-class &&/partials-field "I"))) + +(defn ^:private ^MethodVisitor inc-int! [^MethodVisitor method-writer by] + (doto method-writer + (.visitLdcInsn (int by)) + (.visitInsn Opcodes/IADD))) + +(defn ^:private ^MethodVisitor get-field! [^MethodVisitor method-writer class-name field-name] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD class-name field-name field-sig))) + +(defn ^:private ^MethodVisitor put-field! [^MethodVisitor method-writer class-name field-name field-sig value-thunk] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + value-thunk + (.visitFieldInsn Opcodes/PUTFIELD class-name field-name field-sig))) + +(defn ^:private ^MethodVisitor fill-nulls! [^MethodVisitor method-writer amount] + (doto method-writer + (-> (.visitInsn Opcodes/ACONST_NULL) + (->> (dotimes [_ amount]))))) + +(defn ^:private ^MethodVisitor consecutive-args [^MethodVisitor method-writer start amount] + (doto method-writer + (-> (.visitVarInsn Opcodes/ALOAD (+ start idx)) + (->> (dotimes [idx amount]))))) + +(defn ^:private ^MethodVisitor consecutive-applys [^MethodVisitor method-writer start amount] + (let [max-args-num (min amount &&/num-apply-variants)] + (doto method-writer + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (consecutive-args start max-args-num) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature max-args-num)) + (-> (consecutive-applys (+ start &&/num-apply-variants) (- amount &&/num-apply-variants)) + (->> (when (> amount &&/num-apply-variants))))))) + +(defn ^:private lambda-impl-signature [arity] + (str "(" (&/fold str "" (&/|repeat arity field-sig)) ")" lambda-return-sig)) + +(defn ^:private lambda--signature [env arity] + (if (> arity 1) + (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec arity) field-sig)) ")" + -return) + (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) ")" + -return))) + +(defn ^:private init-function [^MethodVisitor method-writer arity closure-length] + (if (= 1 arity) + (doto method-writer + (.visitLdcInsn (int 0)) + (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")) + (doto method-writer + (.visitVarInsn Opcodes/ILOAD (inc closure-length)) + (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")))) + +(defn ^:private add-lambda- [^ClassWriter class class-name arity env] + (let [closure-length (&/|length env)] + (doto (.visitMethod class Opcodes/ACC_PUBLIC "" (lambda--signature env arity) nil nil) + (.visitCode) + ;; Do normal object initialization + (.visitVarInsn Opcodes/ALOAD 0) + (init-function arity closure-length) + ;; Add all of the closure variables + (-> (put-field! class-name (str &&/closure-prefix ?captured-id) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD (inc ?captured-id))) + (->> (|let [[?name [_ (&o/$captured _ ?captured-id ?source)]] ?name+?captured]) + (doseq [?name+?captured (&/->seq env)]))) + ;; Add all the partial arguments + (-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD partial-register)) + (->> (|let [partial-register (+ (inc idx*) (inc closure-length))]) + (dotimes [idx* (dec arity)]))) + ;; Finish + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + +(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)] + (defn ^:private add-lambda-impl [^ClassWriter class class-name compile arity impl-body] + (let [$begin (new Label)] + (&/with-writer (doto (.visitMethod class impl-flags "impl" (lambda-impl-signature arity) nil nil) + (.visitCode) + (.visitLabel $begin)) + (|do [^MethodVisitor *writer* &/get-writer + ret (compile $begin impl-body) + :let [_ (doto *writer* + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return ret)))))) + +(defn ^:private instance-closure [compile lambda-class arity closed-over] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW lambda-class) + (.visitInsn Opcodes/DUP))] + _ (&/map% (fn [?name+?captured] + (|case ?name+?captured + [?name [_ (&o/$captured _ _ ?source)]] + (compile nil ?source))) + closed-over) + :let [_ (when (> arity 1) + (doto *writer* + (.visitLdcInsn (int 0)) + (fill-nulls! (dec arity))))] + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" (lambda--signature closed-over arity))]] + (return nil))) + +(defn ^:private add-lambda-reset [^ClassWriter class-writer class-name arity env] + (if (> arity 1) + (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) + (.visitCode) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (-> (get-field! class-name (str &&/closure-prefix cidx)) + (->> (dotimes [cidx (&/|length env)]))) + (.visitLdcInsn (int 0)) + (fill-nulls! (dec arity)) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env arity)) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + +(defn ^:private add-lambda-apply-n [^ClassWriter class-writer +degree+ class-name arity env compile impl-body] + (if (> arity 1) + (let [num-partials (dec arity) + $default (new Label) + $labels* (map (fn [_] (new Label)) (repeat num-partials nil)) + $labels (vec (concat $labels* (list $default))) + $end (new Label) + method-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature +degree+) nil nil) + frame-locals (to-array (list class-name "java/lang/Object" "java/lang/Object")) + frame-stack (to-array [Opcodes/INTEGER]) + arity-over-extent (- arity +degree+)] + (do (doto method-writer + (.visitCode) + get-num-partials! + (.visitTableSwitchInsn 0 (dec num-partials) $default (into-array Label $labels*)) + ;; (< stage (- arity +degree+)) + (-> (doto (.visitLabel $label) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (-> (get-field! class-name (str &&/closure-prefix cidx)) + (->> (dotimes [cidx (&/|length env)]))) + get-num-partials! + (inc-int! +degree+) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 +degree+) + (fill-nulls! (- (- num-partials +degree+) stage)) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env arity)) + (.visitJumpInsn Opcodes/GOTO $end)) + (->> (cond (= stage arity-over-extent) + (doto method-writer + (.visitLabel $label) + (.visitVarInsn Opcodes/ALOAD 0) + (-> (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) + (->> (when (not= 0 stage)))) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 +degree+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) + (.visitJumpInsn Opcodes/GOTO $end)) + + (> stage arity-over-extent) + (let [args-to-completion (- arity stage) + args-left (- +degree+ args-to-completion)] + (doto method-writer + (.visitLabel $label) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 args-to-completion) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) + (consecutive-applys (+ 1 args-to-completion) args-left) + (.visitJumpInsn Opcodes/GOTO $end))) + + :else) + (doseq [[stage $label] (map vector (range arity) $labels)]))) + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (return nil))) + (let [$begin (new Label)] + (&/with-writer (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil) + (.visitCode) + (.visitLabel $begin)) + (|do [^MethodVisitor *writer* &/get-writer + ret (compile $begin impl-body) + :let [_ (doto *writer* + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return ret)))) + )) + +;; [Exports] +(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] + (defn compile-function [compile ?prev-writer arity ?scope ?env ?body] + (|do [[file-name _ _] &/cursor + :let [??scope (&/|reverse ?scope) + name (&host/location (&/|tail ??scope)) + class-name (str (&host/->module-class (&/|head ??scope)) "/" name) + [^ClassWriter =class save?] (|case ?prev-writer + (&/$Some _writer) + (&/T [_writer false]) + + (&/$None) + (&/T [(doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version lambda-flags + class-name nil &&/function-class (into-array String []))) + true])) + _ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) &&/arity-field "I" nil (int arity)) + (doto (.visitEnd))) + (-> (doto (.visitField datum-flags captured-name field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [_ (&o/$captured _ ?captured-id ?source)]]) + (doseq [?name+?captured (&/->seq ?env)]))) + (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil) + (doto (.visitEnd)) + (->> (dotimes [idx (dec arity)]))) + (-> (.visitSource file-name nil) + (when save?)) + (add-lambda- class-name arity ?env) + (add-lambda-reset class-name arity ?env) + )] + _ (if (> arity 1) + (add-lambda-impl =class class-name compile arity ?body) + (return nil)) + _ (&/map% #(add-lambda-apply-n =class % class-name arity ?env compile ?body) + (&/|range* 1 (min arity &&/num-apply-variants))) + :let [_ (.visitEnd =class)] + _ (if save? + (&&/save-class! name (.toByteArray =class)) + (return nil))] + (if save? + (instance-closure compile class-name arity ?env) + (return (instance-closure compile class-name arity ?env)))))) diff --git a/luxc/src/lux/compiler/lux.clj b/luxc/src/lux/compiler/lux.clj new file mode 100644 index 000000000..5dc8becc0 --- /dev/null +++ b/luxc/src/lux/compiler/lux.clj @@ -0,0 +1,498 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.lux + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &a] + [module :as &a-module] + [meta :as &a-meta]) + (lux.compiler [base :as &&] + [lambda :as &&lambda])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor) + java.lang.reflect.Field)) + +;; [Exports] +(defn compile-bool [?value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] + (return nil))) + +(do-template [ ] + (defn [value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitLdcInsn ( value)) + (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str "(" ")" (&host-generics/->type-signature ))))]] + (return nil))) + + compile-nat "java/lang/Long" "J" long + compile-int "java/lang/Long" "J" long + compile-frac "java/lang/Long" "J" long + compile-real "java/lang/Double" "D" double + compile-char "java/lang/Character" "C" char + ) + +(defn compile-text [?value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitLdcInsn *writer* ?value)]] + (return nil))) + +(defn compile-tuple [compile ?elems] + (|do [^MethodVisitor *writer* &/get-writer + :let [num-elems (&/|length ?elems)]] + (|case num-elems + 0 + (|do [:let [_ (.visitLdcInsn *writer* &/unit-tag)]] + (return nil)) + + 1 + (compile (&/|head ?elems)) + + _ + (|do [:let [_ (doto *writer* + (.visitLdcInsn (int num-elems)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] + _ (&/map2% (fn [idx elem] + (|do [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + ret (compile elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return ret))) + (&/|range num-elems) ?elems)] + (return nil))))) + +(defn compile-variant [compile tag tail? value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitLdcInsn *writer* (int tag)) + _ (if tail? + (.visitLdcInsn *writer* "") + (.visitInsn *writer* Opcodes/ACONST_NULL))] + _ (compile value) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")]] + (return nil))) + +(defn compile-local [compile ?idx] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] + (return nil))) + +(defn compile-captured [compile ?scope ?captured-id ?source] + (|do [:let [??scope (&/|reverse ?scope)] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD + (str (&host/->module-class (&/|head ??scope)) "/" (&host/location (&/|tail ??scope))) + (str &&/closure-prefix ?captured-id) + "Ljava/lang/Object;"))]] + (return nil))) + +(defn compile-global [compile ?owner-class ?name] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&host/def-name ?name)) &/value-field "Ljava/lang/Object;")]] + (return nil))) + +(defn ^:private compile-apply* [compile ?args] + (|do [^MethodVisitor *writer* &/get-writer + _ (&/map% (fn [?args] + (|do [:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST &&/function-class)] + _ (&/map% compile ?args) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (&/|length ?args)))]] + (return nil))) + (&/|partition &&/num-apply-variants ?args))] + (return nil))) + +(defn compile-apply [compile ?fn ?args] + (|case ?fn + [_ (&o/$var (&/$Global ?module ?name))] + (|do [[_ [_ _ func-obj]] (&a-module/find-def ?module ?name) + class-loader &/loader + :let [func-class (class func-obj) + func-arity (.get ^Field (.getDeclaredField func-class &&/arity-field) nil) + func-partials (.get ^Field (.getDeclaredField (Class/forName "lux.Function" true class-loader) &&/partials-field) func-obj) + num-args (&/|length ?args) + func-class-name (->> func-class .getName &host-generics/->bytecode-class-name)]] + (if (and (= 0 func-partials) + (>= num-args func-arity)) + (|do [_ (compile ?fn) + ^MethodVisitor *writer* &/get-writer + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST func-class-name)] + _ (&/map% compile (&/|take func-arity ?args)) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL func-class-name (if (= 1 func-arity) &&/apply-method "impl") (&&/apply-signature func-arity))] + _ (if (= num-args func-arity) + (return nil) + (compile-apply* compile (&/|drop func-arity ?args)))] + (return nil)) + (|do [_ (compile ?fn)] + (compile-apply* compile ?args)))) + + _ + (|do [_ (compile ?fn)] + (compile-apply* compile ?args)) + )) + +(defn compile-loop [compile-expression register-offset inits body] + (|do [^MethodVisitor *writer* &/get-writer + :let [idxs+inits (&/zip2 (&/|range* 0 (dec (&/|length inits))) + inits)] + _ (&/map% (fn [idx+_init] + (|do [:let [[idx _init] idx+_init + idx+ (+ register-offset idx)] + _ (compile-expression nil _init) + :let [_ (.visitVarInsn *writer* Opcodes/ASTORE idx+)]] + (return nil))) + idxs+inits) + :let [$begin (new Label) + _ (.visitLabel *writer* $begin)]] + (compile-expression $begin body) + )) + +(defn compile-iter [compile $begin register-offset ?args] + (|do [^MethodVisitor *writer* &/get-writer + :let [idxs+args (&/zip2 (&/|range* 0 (dec (&/|length ?args))) + ?args)] + _ (&/map% (fn [idx+?arg] + (|do [:let [[idx ?arg] idx+?arg + idx+ (+ register-offset idx) + already-set? (|case ?arg + [_ (&o/$var (&/$Local l-idx))] + (= idx+ l-idx) + + _ + false)]] + (if already-set? + (return nil) + (compile ?arg)))) + idxs+args) + _ (&/map% (fn [idx+?arg] + (|do [:let [[idx ?arg] idx+?arg + idx+ (+ register-offset idx) + already-set? (|case ?arg + [_ (&o/$var (&/$Local l-idx))] + (= idx+ l-idx) + + _ + false)] + :let [_ (when (not already-set?) + (.visitVarInsn *writer* Opcodes/ASTORE idx+))]] + (return nil))) + (&/|reverse idxs+args)) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]] + (return nil))) + +(defn compile-let [compile _value _register _body] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile _value) + :let [_ (.visitVarInsn *writer* Opcodes/ASTORE _register)] + _ (compile _body)] + (return nil))) + +(defn compile-record-get [compile _value _path] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile _value) + :let [_ (&/|map (fn [step] + (|let [[idx tail?] step] + (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int idx)) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" + (if tail? "product_getRight" "product_getLeft") + "([Ljava/lang/Object;I)Ljava/lang/Object;")))) + _path)]] + (return nil))) + +(defn compile-if [compile _test _then _else] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile _test) + :let [$else (new Label) + $end (new Label) + _ (doto *writer* + &&/unwrap-boolean + (.visitJumpInsn Opcodes/IFEQ $else))] + _ (compile _then) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] + :let [_ (.visitLabel *writer* $else)] + _ (compile _else) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end) + _ (.visitLabel *writer* $end)]] + (return nil))) + +(defn ^:private de-ann [optim] + (|case optim + [_ (&o/$ann value-expr _)] + value-expr + + _ + optim)) + +(defn ^:private throwable->text [^Throwable t] + (let [base (->> t + .getStackTrace + (map str) + (cons (.getMessage t)) + (interpose "\n") + (apply str))] + (if-let [cause (.getCause t)] + (str base "\n\n" "Caused by: " (throwable->text cause)) + base))) + +(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] + (defn compile-def [compile ?name ?body ?meta] + (|do [module-name &/get-module-name + class-loader &/loader] + (|case (&a-meta/meta-get &a-meta/alias-tag ?meta) + (&/$Some (&/$IdentM [r-module r-name])) + (if (= 1 (&/|length ?meta)) + (|do [:let [current-class (&host-generics/->class-name (str (&host/->module-class r-module) "/" (&host/def-name r-name))) + def-class (&&/load-class! class-loader current-class) + def-type (&a-module/def-type r-module r-name) + def-meta ?meta + def-value (-> def-class (.getField &/value-field) (.get nil))] + _ (&/without-repl-closure + (&a-module/define module-name ?name def-type def-meta def-value))] + (return nil)) + (fail (str "[Compilation Error] Aliases cannot contain meta-data: " module-name ";" ?name))) + + (&/$Some _) + (fail "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.") + + _ + (|case (de-ann ?body) + [_ (&o/$function _ _ __scope _ _)] + (|let [[_ (&o/$function _ _arity _scope _captured ?body+)] (&o/shift-function-body (&/|tail __scope) __scope + false + (de-ann ?body))] + (|do [:let [=value-type (&a/expr-type* ?body)] + [file-name _ _] &/cursor + :let [datum-sig "Ljava/lang/Object;" + def-name (&host/def-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version class-flags + current-class nil &&/function-class (into-array String [])) + (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) + (doto (.visitEnd))) + (-> (.visitField field-flags &/value-field datum-sig nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + instancer (&&lambda/compile-function compile (&/$Some =class) _arity _scope _captured ?body+) + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) + (|do [^MethodVisitor **writer** &/get-writer + :let [_ (.visitCode **writer**)] + _ instancer + :let [_ (.visitTypeInsn **writer** Opcodes/CHECKCAST "java/lang/Object") + _ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] + :let [_ (doto **writer** + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd =class)] + _ (&&/save-class! def-name (.toByteArray =class)) + :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) + def-type (&a/expr-type* ?body) + is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) + (&/$Some (&/$BoolM true)) + true + + _ + false) + def-meta ?meta + def-value (-> def-class (.getField &/value-field) (.get nil))] + _ (&/without-repl-closure + (&a-module/define module-name ?name def-type def-meta def-value)) + _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)]) + [true (&/$Some (&/$ListM tags*))] + (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta) + (&/$Some _) + true + + _ + false)] + tags (&/map% (fn [tag*] + (|case tag* + (&/$TextM tag) + (return tag) + + _ + (fail "[Compiler Error] Incorrect format for tags."))) + tags*) + _ (&a-module/declare-tags module-name tags was-exported? def-value)] + (return nil)) + + [false (&/$Some _)] + (fail "[Compiler Error] Can't define tags for non-type.") + + [true (&/$Some _)] + (fail "[Compiler Error] Incorrect format for tags.") + + [_ (&/$None)] + (return nil)) + :let [_ (println 'DEF (str module-name ";" ?name))]] + (return nil))) + + _ + (|do [:let [=value-type (&a/expr-type* ?body)] + [file-name _ _] &/cursor + :let [datum-sig "Ljava/lang/Object;" + def-name (&host/def-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version class-flags + current-class nil "java/lang/Object" (into-array String [])) + (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) + (doto (.visitEnd))) + (-> (.visitField field-flags &/value-field datum-sig nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) + (|do [^MethodVisitor **writer** &/get-writer + :let [_ (.visitCode **writer**)] + _ (compile nil ?body) + :let [_ (.visitTypeInsn **writer** Opcodes/CHECKCAST "java/lang/Object") + _ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] + :let [_ (doto **writer** + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd =class)] + _ (&&/save-class! def-name (.toByteArray =class)) + :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) + def-type (&a/expr-type* ?body) + is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) + (&/$Some (&/$BoolM true)) + true + + _ + false) + def-meta ?meta] + def-value (try (return (-> def-class (.getField &/value-field) (.get nil))) + (catch Throwable t + (&/assert! false (throwable->text t)))) + _ (&/without-repl-closure + (&a-module/define module-name ?name def-type def-meta def-value)) + _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)]) + [true (&/$Some (&/$ListM tags*))] + (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta) + (&/$Some _) + true + + _ + false)] + tags (&/map% (fn [tag*] + (|case tag* + (&/$TextM tag) + (return tag) + + _ + (fail "[Compiler Error] Incorrect format for tags."))) + tags*) + _ (&a-module/declare-tags module-name tags was-exported? def-value)] + (return nil)) + + [false (&/$Some _)] + (fail "[Compiler Error] Can't define tags for non-type.") + + [true (&/$Some _)] + (fail "[Compiler Error] Incorrect format for tags.") + + [_ (&/$None)] + (return nil)) + :let [_ (println 'DEF (str module-name ";" ?name))]] + (return nil))) + )))) + +(defn compile-program [compile ?body] + (|do [module-name &/get-module-name + ^ClassWriter *writer* &/get-writer] + (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) + (.visitCode)) + (|do [^MethodVisitor main-writer &/get-writer + :let [$loop (new Label) + $end (new Label) + _ (doto main-writer + ;; Tail: Begin + (.visitLdcInsn (->> #'&/$Nil meta ::&/idx int)) ;; I + (.visitInsn Opcodes/ACONST_NULL) ;; I? + (.visitLdcInsn &/unit-tag) ;; I?U + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; V + ;; Tail: End + ;; Size: Begin + (.visitVarInsn Opcodes/ALOAD 0) ;; VA + (.visitInsn Opcodes/ARRAYLENGTH) ;; VI + ;; Size: End + ;; Loop: Begin + (.visitLabel $loop) + (.visitLdcInsn (int 1)) ;; VII + (.visitInsn Opcodes/ISUB) ;; VI + (.visitInsn Opcodes/DUP) ;; VII + (.visitJumpInsn Opcodes/IFLT $end) ;; VI + ;; Head: Begin + (.visitInsn Opcodes/DUP) ;; VII + (.visitVarInsn Opcodes/ALOAD 0) ;; VIIA + (.visitInsn Opcodes/SWAP) ;; VIAI + (.visitInsn Opcodes/AALOAD) ;; VIO + (.visitInsn Opcodes/SWAP) ;; VOI + (.visitInsn Opcodes/DUP_X2) ;; IVOI + (.visitInsn Opcodes/POP) ;; IVO + ;; Head: End + ;; Tuple: Begin + (.visitLdcInsn (int 2)) ;; IVOS + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; IVO2 + (.visitInsn Opcodes/DUP_X1) ;; IV2O2 + (.visitInsn Opcodes/SWAP) ;; IV22O + (.visitLdcInsn (int 0)) ;; IV22OI + (.visitInsn Opcodes/SWAP) ;; IV22IO + (.visitInsn Opcodes/AASTORE) ;; IV2 + (.visitInsn Opcodes/DUP_X1) ;; I2V2 + (.visitInsn Opcodes/SWAP) ;; I22V + (.visitLdcInsn (int 1)) ;; I22VI + (.visitInsn Opcodes/SWAP) ;; I22IV + (.visitInsn Opcodes/AASTORE) ;; I2 + ;; Tuple: End + ;; Cons: Begin + (.visitLdcInsn (->> #'&/$Cons meta ::&/idx int)) ;; I2I + (.visitLdcInsn "") ;; I2I? + (.visitInsn Opcodes/DUP2_X1) ;; II?2I? + (.visitInsn Opcodes/POP2) ;; II?2 + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; IV + ;; Cons: End + (.visitInsn Opcodes/SWAP) ;; VI + (.visitJumpInsn Opcodes/GOTO $loop) + ;; Loop: End + (.visitLabel $end) ;; VI + (.visitInsn Opcodes/POP) ;; V + (.visitVarInsn Opcodes/ASTORE (int 0)) ;; + ) + ] + _ (compile ?body) + :let [_ (doto main-writer + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitInsn Opcodes/ACONST_NULL) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] + :let [_ (doto main-writer + (.visitInsn Opcodes/POP) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) diff --git a/luxc/src/lux/compiler/module.clj b/luxc/src/lux/compiler/module.clj new file mode 100644 index 000000000..03bc311f2 --- /dev/null +++ b/luxc/src/lux/compiler/module.clj @@ -0,0 +1,28 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.module + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]] + [type :as &type]) + [lux.analyser.module :as &module])) + +;; [Exports] +(def tag-groups + "(Lux (List (, Text (List Text))))" + (|do [module &/get-current-module] + (return (&/|map (fn [pair] + (|case pair + [name [tags exported? _]] + (&/T [name (&/|map (fn [tag] + (|let [[t-prefix t-name] tag] + t-name)) + tags)]))) + (&/get$ &module/$types module))) + )) diff --git a/luxc/src/lux/compiler/parallel.clj b/luxc/src/lux/compiler/parallel.clj new file mode 100644 index 000000000..8f6fee99d --- /dev/null +++ b/luxc/src/lux/compiler/parallel.clj @@ -0,0 +1,47 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.parallel + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]]))) + +;; [Utils] +(def ^:private !state! (ref {})) + +(def ^:private get-compiler + (fn [compiler] + (return* compiler compiler))) + +;; [Exports] +(defn setup! + "Must always call this function before using parallel compilation to make sure that the state that is being tracked is in proper shape." + [] + (dosync (ref-set !state! {}))) + +(defn parallel-compilation [compile-module*] + (fn [module-name] + (|do [compiler get-compiler + :let [[task new?] (dosync (if-let [existing-task (get @!state! module-name)] + (&/T [existing-task false]) + (let [new-task (promise)] + (do (alter !state! assoc module-name new-task) + (&/T [new-task true]))))) + _ (when new? + (.start (new Thread + (fn [] + (let [out-str (with-out-str + (|case (&/run-state (compile-module* module-name) + compiler) + (&/$Right post-compiler _) + (deliver task (&/$Right post-compiler)) + + (&/$Left ?error) + (deliver task (&/$Left ?error))))] + (&/|log! out-str))))))]] + (return task)))) diff --git a/luxc/src/lux/host.clj b/luxc/src/lux/host.clj new file mode 100644 index 000000000..39e659964 --- /dev/null +++ b/luxc/src/lux/host.clj @@ -0,0 +1,432 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.host + (:require (clojure [string :as string] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [type :as &type]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics]) + (:import (java.lang.reflect Field Method Constructor Modifier Type + GenericArrayType ParameterizedType TypeVariable) + (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Constants] +(def function-class "lux.Function") +(def module-separator "/") +(def class-name-separator ".") +(def class-separator "/") +(def bytecode-version Opcodes/V1_6) + +;; [Resources] +(defn ^String ->module-class [old] + old) + +(def ->package ->module-class) + +(defn unfold-array [type] + "(-> Type (, Int Type))" + (|case type + (&/$HostT "#Array" (&/$Cons param (&/$Nil))) + (|let [[count inner] (unfold-array param)] + (&/T [(inc count) inner])) + + _ + (&/T [0 type]))) + +(let [ex-type-class (str "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";") + object-array (str "[" "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";")] + (defn ->java-sig [^objects type] + "(-> Type (Lux Text))" + (|case type + (&/$HostT ?name params) + (cond (= &host-type/array-data-tag ?name) (|do [:let [[level base] (unfold-array type)] + base-sig (|case base + (&/$HostT base-class _) + (return (&host-generics/->type-signature base-class)) + + _ + (->java-sig base))] + (return (str (->> (&/|repeat level "[") (&/fold str "")) + base-sig))) + (= &host-type/null-data-tag ?name) (return (&host-generics/->type-signature "java.lang.Object")) + :else (return (&host-generics/->type-signature ?name))) + + (&/$LambdaT _ _) + (return (&host-generics/->type-signature function-class)) + + (&/$UnitT) + (return "V") + + (&/$SumT _) + (return object-array) + + (&/$ProdT _) + (return object-array) + + (&/$NamedT ?name ?type) + (->java-sig ?type) + + (&/$AppT ?F ?A) + (|do [type* (&type/apply-type ?F ?A)] + (->java-sig type*)) + + (&/$ExT _) + (return ex-type-class) + + _ + (assert false (str '->java-sig " " (&type/show-type type))) + ))) + +(do-template [ ] + (defn [class-loader target field] + (|let [target-class (Class/forName target true class-loader)] + (if-let [^Type gtype (first (for [^Field =field (seq (.getDeclaredFields target-class)) + :when (and (.equals ^Object field (.getName =field)) + (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] + (.getGenericType =field)))] + (|let [gvars (->> target-class .getTypeParameters seq &/->list)] + (return (&/T [gvars gtype]))) + (&/fail-with-loc (str "[Host Error] Field does not exist: " target "." field))))) + + lookup-static-field true + lookup-field false + ) + +(do-template [ ] + (defn [class-loader target method-name args] + (|let [target-class (Class/forName target true class-loader)] + (if-let [[^Method method ^Class declarer] (first (for [^Method =method (.getDeclaredMethods target-class) + :when (and (.equals ^Object method-name (.getName =method)) + (.equals ^Object (Modifier/isStatic (.getModifiers =method))) + (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types)))))] + [=method + (.getDeclaringClass =method)]))] + (if (= target-class declarer) + (|let [parent-gvars (->> target-class .getTypeParameters seq &/->list) + gvars (->> method .getTypeParameters seq &/->list) + gargs (->> method .getGenericParameterTypes seq &/->list) + _ (when (.getAnnotation method java.lang.Deprecated) + (println (str "[Host Warning] Deprecated method: " target "." method-name " " (->> args &/->seq print-str))))] + (return (&/T [(.getGenericReturnType method) + (->> method .getExceptionTypes &/->list (&/|map #(.getName ^Class %))) + parent-gvars + gvars + gargs]))) + (&/fail-with-loc (str "[Host Error] " " method " (pr-str method-name) " for " "(" (->> args (&/|interpose ", ") (&/fold str "")) ")" " belongs to parent " (.getName declarer) " instead of " target))) + (&/fail-with-loc (str "[Host Error] " " method does not exist: " target "." method-name " " "(" (->> args (&/|interpose ", ") (&/fold str "")) ")"))))) + + lookup-static-method true "Static" + lookup-virtual-method false "Virtual" + ) + +(defn lookup-constructor [class-loader target args] + (let [target-class (Class/forName target true class-loader)] + (if-let [^Constructor ctor (first (for [^Constructor =method (.getDeclaredConstructors target-class) + :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types))))] + =method))] + (|let [gvars (->> target-class .getTypeParameters seq &/->list) + gargs (->> ctor .getGenericParameterTypes seq &/->list) + exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName ^Class %))) + _ (when (.getAnnotation ctor java.lang.Deprecated) + (println (str "[Host Warning] Deprecated constructor: " target " " (->> args &/->seq print-str))))] + (return (&/T [exs gvars gargs]))) + (&/fail-with-loc (str "[Host Error] Constructor does not exist: " target " " (->> args &/->seq print-str)))))) + +(defn abstract-methods [class-loader super-class] + "(-> ClassLoader SuperClassDecl (Lux (List (, Text (List Text)))))" + (|let [[super-name super-params] super-class] + (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName super-name true class-loader)) + :when (Modifier/isAbstract (.getModifiers =method))] + (&/T [(.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))])))))) + +(defn def-name [name] + (str (&/normalize-name name) "_" (Long/toUnsignedString (hash name)))) + +(defn location [scope] + (let [scope (&/$Cons (def-name (&/|head scope)) + (&/|map &/normalize-name (&/|tail scope)))] + (->> scope + (&/|interpose "$") + (&/fold str "")))) + +(defn primitive-jvm-type? [type] + (case type + ("boolean" "byte" "short" "int" "long" "float" "double" "char") + true + ;; else + false)) + +(defn dummy-value [^MethodVisitor writer class] + (|case class + (&/$GenericClass "boolean" (&/$Nil)) + (doto writer + (.visitLdcInsn false)) + + (&/$GenericClass "byte" (&/$Nil)) + (doto writer + (.visitLdcInsn (byte 0))) + + (&/$GenericClass "short" (&/$Nil)) + (doto writer + (.visitLdcInsn (short 0))) + + (&/$GenericClass "int" (&/$Nil)) + (doto writer + (.visitLdcInsn (int 0))) + + (&/$GenericClass "long" (&/$Nil)) + (doto writer + (.visitLdcInsn (long 0))) + + (&/$GenericClass "float" (&/$Nil)) + (doto writer + (.visitLdcInsn (float 0.0))) + + (&/$GenericClass "double" (&/$Nil)) + (doto writer + (.visitLdcInsn (double 0.0))) + + (&/$GenericClass "char" (&/$Nil)) + (doto writer + (.visitLdcInsn (char 0))) + + _ + (doto writer + (.visitInsn Opcodes/ACONST_NULL)))) + +(defn ^:private dummy-return [^MethodVisitor writer output] + (|case output + (&/$GenericClass "void" (&/$Nil)) + (.visitInsn writer Opcodes/RETURN) + + (&/$GenericClass "boolean" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "byte" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "short" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "int" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "long" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/LRETURN)) + + (&/$GenericClass "float" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/FRETURN)) + + (&/$GenericClass "double" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/DRETURN)) + + (&/$GenericClass "char" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + _ + (doto writer + (dummy-value output) + (.visitInsn Opcodes/ARETURN)))) + +(defn ^:private ->dummy-type [real-name store-name gclass] + (|case gclass + (&/$GenericClass _name _params) + (if (= real-name _name) + (&/$GenericClass store-name (&/|map (partial ->dummy-type real-name store-name) _params)) + gclass) + + _ + gclass)) + +(def init-method-name "") + +(defn ^:private dummy-ctor [^MethodVisitor writer real-name store-name super-class ctor-args] + (|let [ctor-arg-types (->> ctor-args (&/|map (comp &host-generics/->type-signature (comp (partial ->dummy-type real-name store-name) &/|first))) (&/fold str ""))] + (doto writer + (.visitVarInsn Opcodes/ALOAD 0) + (-> (doto (dummy-value arg-type) + (-> (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name arg-type)) + (->> (when (not (primitive-jvm-type? arg-type)))))) + (->> (doseq [ctor-arg (&/->seq ctor-args) + :let [;; arg-term (&/|first ctor-arg) + arg-type (->dummy-type real-name store-name (&/|first ctor-arg))]]))) + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) init-method-name (str "(" ctor-arg-types ")V")) + (.visitInsn Opcodes/RETURN)))) + +(defn ^:private compile-dummy-method [^ClassWriter =class real-name store-name super-class method-def] + (|case method-def + (&/$ConstructorMethodSyntax =privacy-modifier ?strict =anns =gvars =exceptions =inputs =ctor-args body) + (|let [=output (&/$GenericClass "void" (&/|list)) + method-decl [init-method-name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class Opcodes/ACC_PUBLIC + init-method-name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-ctor real-name store-name super-class =ctor-args) + (.visitMaxs 0 0) + (.visitEnd))) + + (&/$VirtualMethodSyntax =name =privacy-modifier =final? ?strict =anns =gvars =exceptions =inputs =output body) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC + (if =final? Opcodes/ACC_FINAL 0)) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return =output) + (.visitMaxs 0 0) + (.visitEnd))) + + (&/$OverridenMethodSyntax =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class Opcodes/ACC_PUBLIC + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return =output) + (.visitMaxs 0 0) + (.visitEnd))) + + (&/$StaticMethodSyntax =name =privacy-modifier ?strict =anns =gvars =exceptions =inputs =output body) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return =output) + (.visitMaxs 0 0) + (.visitEnd))) + + (&/$AbstractMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + (.visitEnd))) + + (&/$NativeMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + (.visitEnd))) + + _ + (assert false (println-str 'compile-dummy-method (&/adt->text method-def))) + )) + +(defn privacy-modifier->flag [privacy-modifier] + "(-> PrivacyModifier Int)" + (|case privacy-modifier + (&/$PublicPM) Opcodes/ACC_PUBLIC + (&/$PrivatePM) Opcodes/ACC_PRIVATE + (&/$ProtectedPM) Opcodes/ACC_PROTECTED + (&/$DefaultPM) 0 + )) + +(defn state-modifier->flag [state-modifier] + "(-> StateModifier Int)" + (|case state-modifier + (&/$DefaultSM) 0 + (&/$VolatileSM) Opcodes/ACC_VOLATILE + (&/$FinalSM) Opcodes/ACC_FINAL)) + +(defn inheritance-modifier->flag [inheritance-modifier] + "(-> InheritanceModifier Int)" + (|case inheritance-modifier + (&/$DefaultIM) 0 + (&/$AbstractIM) Opcodes/ACC_ABSTRACT + (&/$FinalIM) Opcodes/ACC_FINAL)) + +(defn use-dummy-class [class-decl super-class interfaces ctor-args fields methods] + (|do [module &/get-module-name + :let [[?name ?params] class-decl + dummy-name ?name;; (str ?name "__DUMMY__") + dummy-full-name (str module "/" dummy-name) + real-name (str (&host-generics/->class-name module) "." ?name) + store-name (str (&host-generics/->class-name module) "." dummy-name) + class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons super-class interfaces)) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + dummy-full-name + (if (= "" class-signature) nil class-signature) + (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) + (->> interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))) + _ (&/|map (fn [field] + (|case field + (&/$ConstantFieldAnalysis =name =anns =type ?value) + (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) =name + (&host-generics/gclass->simple-signature =type) + (&host-generics/gclass->signature =type) + nil) + (.visitEnd)) + + (&/$VariableFieldAnalysis =name =privacy-modifier =state-modifier =anns =type) + (doto (.visitField =class (+ Opcodes/ACC_PUBLIC (state-modifier->flag =state-modifier)) =name + (&host-generics/gclass->simple-signature =type) + (&host-generics/gclass->signature =type) + nil) + (.visitEnd)) + )) + fields) + _ (&/|map (partial compile-dummy-method =class real-name store-name super-class) methods) + bytecode (.toByteArray (doto =class .visitEnd))] + ^ClassLoader loader &/loader + !classes &/classes + :let [_ (swap! !classes assoc store-name bytecode) + _ (.loadClass loader store-name)] + _ (&/push-dummy-name real-name store-name)] + (return nil))) diff --git a/luxc/src/lux/host/generics.clj b/luxc/src/lux/host/generics.clj new file mode 100644 index 000000000..cfd0d2d54 --- /dev/null +++ b/luxc/src/lux/host/generics.clj @@ -0,0 +1,205 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.host.generics + (:require (clojure [string :as string] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let |case]])) + (:import java.util.regex.Pattern)) + +(declare gclass->signature) + +(do-template [ ] + (let [regex (-> Pattern/quote re-pattern)] + (defn [old] + (string/replace old regex ))) + + ;; ->class + ^String ->bytecode-class-name "." "/" + ;; ->class-name + ^String ->class-name "/" "." + ) + +;; ->type-signature +(defn ->type-signature [class] + (case class + "void" "V" + "boolean" "Z" + "byte" "B" + "short" "S" + "int" "I" + "long" "J" + "float" "F" + "double" "D" + "char" "C" + ;; else + (let [class* (->bytecode-class-name class)] + (if (.startsWith class* "[") + class* + (str "L" class* ";"))) + )) + +(defn super-class-name [super] + "(-> GenericSuperClassDecl Text)" + (|let [[super-name super-params] super] + super-name)) + +(defn formal-type-parameter->signature [param] + (|let [[pname pbounds] param] + (|case pbounds + (&/$Nil) + pname + + _ + (->> pbounds + (&/|map (fn [pbound] (str ": " (gclass->signature pbound)))) + (&/|interpose " ") + (str pname " ")) + ))) + +(defn formal-type-parameters->signature [params] + (if (&/|empty? params) + "" + (str "<" (->> params (&/|map formal-type-parameter->signature) (&/|interpose " ") (&/fold str "")) ">"))) + +(defn gclass->signature [super] + "(-> GenericClass Text)" + (|case super + (&/$GenericTypeVar name) + (str "T" name ";") + + (&/$GenericWildcard (&/$None)) + "*" + + (&/$GenericWildcard (&/$Some [(&/$UpperBound) ?bound])) + (str "+" (gclass->signature ?bound)) + + (&/$GenericWildcard (&/$Some [(&/$LowerBound) ?bound])) + (str "-" (gclass->signature ?bound)) + + (&/$GenericClass ^String name params) + (case name + "void" "V" + "boolean" "Z" + "byte" "B" + "short" "S" + "int" "I" + "long" "J" + "float" "F" + "double" "D" + "char" "C" + ;; else + (if (.startsWith name "[") + name + (let [params* (if (&/|empty? params) + "" + (str "<" (->> params (&/|map gclass->signature) (&/|interpose "") (&/fold str "")) ">"))] + (str "L" (->bytecode-class-name name) params* ";")))) + + (&/$GenericArray param) + (str "[" (gclass->signature param)))) + +(defn gsuper-decl->signature [super] + "(-> GenericSuperClassDecl Text)" + (|let [[super-name super-params] super + params* (if (&/|empty? super-params) + "" + (str "<" (->> super-params (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")) ">"))] + (str "L" (->bytecode-class-name super-name) params* ";"))) + +(defn gclass-decl->signature [class-decl supers] + "(-> GenericClassDecl (List GenericSuperClassDecl) Text)" + (|let [[class-name class-vars] class-decl + vars-section (formal-type-parameters->signature class-vars) + super-section (->> (&/|map gsuper-decl->signature supers) (&/|interpose " ") (&/fold str ""))] + (str vars-section super-section))) + +(let [object-simple-signature (->type-signature "java.lang.Object")] + (defn gclass->simple-signature [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar name) + object-simple-signature + + (&/$GenericWildcard _) + object-simple-signature + + (&/$GenericClass name params) + (->type-signature name) + + (&/$GenericArray param) + (str "[" (gclass->simple-signature param)) + + _ + (assert false (str 'gclass->simple-signature " " (&/adt->text gclass)))))) + +(defn gclass->class-name [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar name) + (->bytecode-class-name "java.lang.Object") + + (&/$GenericWildcard _) + (->bytecode-class-name "java.lang.Object") + + (&/$GenericClass name params) + (->bytecode-class-name name) + + (&/$GenericArray param) + (str "[" (gclass->class-name param)) + + _ + (assert false (str 'gclass->class-name " " (&/adt->text gclass))))) + +(let [object-bc-name (->bytecode-class-name "java.lang.Object")] + (defn gclass->bytecode-class-name* [gclass type-env] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar name) + object-bc-name + + (&/$GenericWildcard _) + object-bc-name + + (&/$GenericClass name params) + ;; When referring to type-parameters during class or method + ;; definition, a type-environment is set for storing the names + ;; of such parameters. + ;; When a "class" shows up with the name of one of those + ;; parameters, it must be detected, and the bytecode class-name + ;; must correspond to Object's. + (if (&/|get name type-env) + object-bc-name + (->bytecode-class-name name)) + + (&/$GenericArray param) + (assert false "gclass->bytecode-class-name* doesn't work on arrays.")))) + +(let [object-bc-name (->bytecode-class-name "java.lang.Object")] + (defn gclass->bytecode-class-name [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar name) + object-bc-name + + (&/$GenericWildcard _) + object-bc-name + + (&/$GenericClass name params) + (->bytecode-class-name name) + + (&/$GenericArray param) + (assert false "gclass->bytecode-class-name doesn't work on arrays.")))) + +(defn method-signatures [method-decl] + (|let [[=name =anns =gvars =exceptions =inputs =output] method-decl + simple-signature (str "(" (&/fold str "" (&/|map gclass->simple-signature =inputs)) ")" (gclass->simple-signature =output)) + generic-signature (str (formal-type-parameters->signature =gvars) + "(" (&/fold str "" (&/|map gclass->signature =inputs)) ")" + (gclass->signature =output) + (->> =exceptions (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")))] + (&/T [simple-signature generic-signature]))) diff --git a/luxc/src/lux/lexer.clj b/luxc/src/lux/lexer.clj new file mode 100644 index 000000000..f519aa563 --- /dev/null +++ b/luxc/src/lux/lexer.clj @@ -0,0 +1,254 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.lexer + (:require (clojure [template :refer [do-template]] + [string :as string]) + (lux [base :as & :refer [defvariant |do return* return fail fail* |case]] + [reader :as &reader]) + [lux.analyser.module :as &module])) + +;; [Tags] +(defvariant + ("White_Space" 1) + ("Comment" 1) + ("Bool" 1) + ("Nat" 1) + ("Int" 1) + ("Frac" 1) + ("Real" 1) + ("Char" 1) + ("Text" 1) + ("Symbol" 1) + ("Tag" 1) + ("Open_Paren" 0) + ("Close_Paren" 0) + ("Open_Bracket" 0) + ("Close_Bracket" 0) + ("Open_Brace" 0) + ("Close_Brace" 0) + ) + +;; [Utils] +(defn ^:private escape-char [escaped] + "(-> Text (Lux Text))" + (cond (.equals ^Object escaped "\\t") (return "\t") + (.equals ^Object escaped "\\b") (return "\b") + (.equals ^Object escaped "\\n") (return "\n") + (.equals ^Object escaped "\\r") (return "\r") + (.equals ^Object escaped "\\f") (return "\f") + (.equals ^Object escaped "\\\"") (return "\"") + (.equals ^Object escaped "\\\\") (return "\\") + :else + (&/fail-with-loc (str "[Lexer Error] Unknown escape character: " escaped)))) + +(defn ^:private escape-char* [escaped] + "(-> Text Text)" + (cond (.equals ^Object escaped "\\t") "\t" + (.equals ^Object escaped "\\b") "\b" + (.equals ^Object escaped "\\n") "\n" + (.equals ^Object escaped "\\r") "\r" + (.equals ^Object escaped "\\f") "\f" + (.equals ^Object escaped "\\\"") "\"" + (.equals ^Object escaped "\\\\") "\\" + :else + (assert false (str "[Lexer Error] Unknown escape character: " escaped)))) + +(defn ^:private clean-line [^String raw-line] + "(-> Text Text)" + (let [line-length (.length raw-line) + buffer (new StringBuffer line-length)] + (loop [idx 0] + (if (< idx line-length) + (let [current-char (.charAt raw-line idx)] + (if (= \\ current-char) + (do (assert (< (+ 1 idx) line-length) (str "[Lexer Error] Text is too short for escaping: " raw-line " " idx)) + (case (.charAt raw-line (+ 1 idx)) + \t (do (.append buffer "\t") + (recur (+ 2 idx))) + \b (do (.append buffer "\b") + (recur (+ 2 idx))) + \n (do (.append buffer "\n") + (recur (+ 2 idx))) + \r (do (.append buffer "\r") + (recur (+ 2 idx))) + \f (do (.append buffer "\f") + (recur (+ 2 idx))) + \" (do (.append buffer "\"") + (recur (+ 2 idx))) + \\ (do (.append buffer "\\") + (recur (+ 2 idx))) + \u (do (assert (< (+ 5 idx) line-length) (str "[Lexer Error] Text is too short for unicode-escaping: " raw-line " " idx)) + (.append buffer (char (Integer/valueOf (.substring raw-line (+ 2 idx) (+ 6 idx)) 16))) + (recur (+ 6 idx))) + ;; else + (assert false (str "[Lexer Error] Invalid escaping syntax: " raw-line " " idx)))) + (do (.append buffer current-char) + (recur (+ 1 idx))))) + (.toString buffer))))) + +(defn ^:private lex-text-body [multi-line? offset] + (|do [[_ eol? ^String pre-quotes**] (&reader/read-regex #"^([^\"]*)") + ^String pre-quotes* (if multi-line? + (|do [:let [empty-line? (and eol? (= "" pre-quotes**))] + _ (&/assert! (or empty-line? + (>= (.length pre-quotes**) offset)) + "Each line of a multi-line text must have an appropriate offset!")] + (return (if empty-line? + "\n" + (str "\n" (.substring pre-quotes** offset))))) + (return pre-quotes**)) + [pre-quotes post-quotes] (if (.endsWith pre-quotes* "\\") + (if eol? + (&/fail-with-loc "[Lexer Error] Can't leave dangling back-slash \\") + (if (if-let [^String back-slashes (re-find #"\\+$" pre-quotes*)] + (odd? (.length back-slashes))) + (|do [[_ eol?* _] (&reader/read-regex #"^([\"])") + next-part (lex-text-body eol?* offset)] + (return (&/T [(.substring pre-quotes* 0 (dec (.length pre-quotes*))) + (str "\"" next-part)]))) + (|do [post-quotes* (lex-text-body false offset)] + (return (&/T [pre-quotes* post-quotes*]))))) + (if eol? + (|do [next-part (lex-text-body true offset)] + (return (&/T [pre-quotes* + next-part]))) + (return (&/T [pre-quotes* ""]))))] + (return (str (clean-line pre-quotes) post-quotes)))) + +(def lex-text + (|do [[meta _ _] (&reader/read-text "\"") + :let [[_ _ _column] meta] + token (lex-text-body false (inc _column)) + _ (&reader/read-text "\"")] + (return (&/T [meta ($Text token)])))) + +(def +ident-re+ + #"^([^0-9\[\]\{\}\(\)\s\"#;][^\[\]\{\}\(\)\s\"#;]*)") + +;; [Lexers] +(def ^:private lex-white-space + (|do [[meta _ white-space] (&reader/read-regex #"^(\s+|$)")] + (return (&/T [meta ($White_Space white-space)])))) + +(def ^:private lex-single-line-comment + (|do [_ (&reader/read-text "##") + [meta _ comment] (&reader/read-regex #"^(.*)$")] + (return (&/T [meta ($Comment comment)])))) + +(defn ^:private lex-multi-line-comment [_] + (|do [_ (&reader/read-text "#(") + [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex+ #"(?is)^(?!#\()((?!\)#).)*")] + (return (&/T [meta comment]))) + (|do [[meta pre] (&reader/read-regex+ #"(?is)^((?!#\().)*") + [_ ($Comment inner)] (lex-multi-line-comment nil) + [_ post] (&reader/read-regex+ #"(?is)^((?!\)#).)*")] + (return (&/T [meta (str pre "#(" inner ")#" post)]))))) + _ (&reader/read-text ")#")] + (return (&/T [meta ($Comment comment)])))) + +(def ^:private lex-comment + (&/try-all% (&/|list lex-single-line-comment + (lex-multi-line-comment nil)))) + +(do-template [ ] + (def + (|do [[meta _ token] (&reader/read-regex )] + (return (&/T [meta ( token)])))) + + lex-bool $Bool #"^(true|false)" + ) + +(do-template [ ] + (def + (|do [[meta _ token] (&reader/read-regex )] + (return (&/T [meta ( (string/replace token #",|_" ""))])))) + + lex-nat $Nat #"^\+(0|[1-9][0-9,_]*)" + lex-int $Int #"^-?(0|[1-9][0-9,_]*)" + lex-frac $Frac #"^(\.[0-9,_]+)" + lex-real $Real #"^-?(0\.[0-9,_]+|[1-9][0-9,_]*\.[0-9,_]+)(e-?[1-9][0-9,_]*)?" + ) + +(def lex-char + (|do [[meta _ _] (&reader/read-text "#\"") + token (&/try-all% (&/|list (|do [[_ _ escaped] (&reader/read-regex #"^(\\.)")] + (escape-char escaped)) + (|do [[_ _ ^String unicode] (&reader/read-regex #"^(\\u[0-9a-fA-F]{4})")] + (return (str (char (Integer/valueOf (.substring unicode 2) 16))))) + (|do [[_ _ char] (&reader/read-regex #"^(.)")] + (return char)))) + _ (&reader/read-text "\"")] + (return (&/T [meta ($Char token)])))) + +(def ^:private lex-ident + (&/try-all-% "[Reader Error]" + (&/|list (|do [[meta _ token] (&reader/read-regex +ident-re+) + [_ _ got-it?] (&reader/read-text? ";")] + (|case got-it? + (&/$Some _) + (|do [[_ _ local-token] (&reader/read-regex +ident-re+) + ? (&module/exists? token)] + (if ? + (return (&/T [meta (&/T [token local-token])])) + (|do [unaliased (&module/dealias token)] + (return (&/T [meta (&/T [unaliased local-token])]))))) + + (&/$None) + (return (&/T [meta (&/T ["" token])])))) + (|do [[meta _ _] (&reader/read-text ";;") + [_ _ token] (&reader/read-regex +ident-re+) + module-name &/get-module-name] + (return (&/T [meta (&/T [module-name token])]))) + (|do [[meta _ _] (&reader/read-text ";") + [_ _ token] (&reader/read-regex +ident-re+)] + (return (&/T [meta (&/T ["lux" token])]))) + ))) + +(def ^:private lex-symbol + (|do [[meta ident] lex-ident] + (return (&/T [meta ($Symbol ident)])))) + +(def ^:private lex-tag + (|do [[meta _ _] (&reader/read-text "#") + [_ ident] lex-ident] + (return (&/T [meta ($Tag ident)])))) + +(do-template [ ] + (def + (|do [[meta _ _] (&reader/read-text )] + (return (&/T [meta ])))) + + ^:private lex-open-paren "(" $Open_Paren + ^:private lex-close-paren ")" $Close_Paren + ^:private lex-open-bracket "[" $Open_Bracket + ^:private lex-close-bracket "]" $Close_Bracket + ^:private lex-open-brace "{" $Open_Brace + ^:private lex-close-brace "}" $Close_Brace + ) + +(def ^:private lex-delimiter + (&/try-all% (&/|list lex-open-paren + lex-close-paren + lex-open-bracket + lex-close-bracket + lex-open-brace + lex-close-brace))) + +;; [Exports] +(def lex + (&/try-all-% "[Reader Error]" + (&/|list lex-white-space + lex-comment + lex-bool + lex-nat + lex-real + lex-frac + lex-int + lex-char + lex-text + lex-symbol + lex-tag + lex-delimiter))) diff --git a/luxc/src/lux/lib/loader.clj b/luxc/src/lux/lib/loader.clj new file mode 100644 index 000000000..e8310f9f0 --- /dev/null +++ b/luxc/src/lux/lib/loader.clj @@ -0,0 +1,54 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.lib.loader + (:refer-clojure :exclude [load]) + (:require (lux [base :as & :refer [|let |do return fail return* fail* |case]])) + (:import (java.io InputStream + File + FileInputStream + ByteArrayInputStream + ByteArrayOutputStream) + java.util.jar.JarInputStream)) + +;; [Utils] +(defn ^:private fetch-libs [] + (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader) + (.getURLs) + seq + (map #(.getFile ^java.net.URL %)) + (filter #(.endsWith ^String % ".jar")) + (map #(new File ^String %)))) + +(let [init-capacity (* 100 1024) + buffer-size 1024] + (defn ^:private ^"[B" read-stream [^InputStream is] + (let [buffer (byte-array buffer-size)] + (with-open [os (new ByteArrayOutputStream init-capacity)] + (loop [bytes-read (.read is buffer 0 buffer-size)] + (when (not= -1 bytes-read) + (do (.write os buffer 0 bytes-read) + (recur (.read is buffer 0 buffer-size))))) + (.toByteArray os))))) + +(defn ^:private unpackage [^File lib-file] + (let [is (->> lib-file + (new FileInputStream) + (new JarInputStream))] + (loop [lib-data {} + entry (.getNextJarEntry is)] + (if entry + (if (.endsWith (.getName entry) ".lux") + (recur (assoc lib-data (.getName entry) (new String (read-stream is))) + (.getNextJarEntry is)) + (recur lib-data + (.getNextJarEntry is))) + lib-data)))) + +;; [Exports] +(defn load [] + (->> (fetch-libs) + (map unpackage) + (reduce merge {}))) diff --git a/luxc/src/lux/optimizer.clj b/luxc/src/lux/optimizer.clj new file mode 100644 index 000000000..5c30dc44f --- /dev/null +++ b/luxc/src/lux/optimizer.clj @@ -0,0 +1,1202 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. +(ns lux.optimizer + (:require (lux [base :as & :refer [|let |do return fail return* fail* |case defvariant]]) + (lux.analyser [base :as &a] + [case :as &a-case]))) + +;; [Tags] +(defvariant + ;; These tags just have a one-to-one correspondence with Analysis data-structures. + ("bool" 1) + ("nat" 1) + ("int" 1) + ("frac" 1) + ("real" 1) + ("char" 1) + ("text" 1) + ("variant" 3) + ("tuple" 1) + ("apply" 2) + ("case" 2) + ("function" 5) + ("ann" 2) + ("var" 1) + ("captured" 3) + ("proc" 3) + + ;; These other tags represent higher-order constructs that manifest + ;; themselves as patterns in the code. + ;; Lux doesn't formally provide these features, but some macros + ;; expose ways to implement them in terms of the other (primitive) + ;; features. + ;; The optimizer looks for those usage patterns and transforms them + ;; into explicit constructs, which are then subject to specialized optimizations. + + ;; Loop scope, for doing loop inlining + ("loop" 3) ;; {register-offset Int, inits (List Optimized), body Optimized} + ;; This is loop iteration, as expected in imperative programming. + ("iter" 2) ;; {register-offset Int, vals (List Optimized)} + ;; This is a simple let-expression, as opposed to the more general pattern-matching. + ("let" 3) + ;; This is an access to a record's member. It can be multi-level: + ;; e.g. record.l1.l2.l3 + ;; The record-get token stores the path, for simpler compilation. + ("record-get" 2) + ;; Regular, run-of-the-mill if expressions. + ("if" 3) + ) + +;; [Utils] + +;; [[Pattern-Matching Traversal Optimization]] + +;; This represents an alternative way to view pattern-matching. +;; The PM that Lux provides has declarative semantics, with the user +;; specifying how his data is shaped, but not how to traverse it. +;; The optimizer's PM is operational in nature, and relies on +;; specifying a path of traversal, with a variety of operations that +;; can be done along the way. +;; The algorithm relies on looking at pattern-matching as traversing a +;; (possibly) branching path, where each step along the path +;; corresponds to a value, the ends of the path are the jumping-off +;; points for the bodies of branches, and branching decisions can be +;; backtracked, if they don't result in a valid jump. +(defvariant + ;; Throw away the current data-node (CDN). It's useless. + ("PopPM" 0) + ;; Store the CDN in a register. + ("BindPM" 1) + ;; Compare the CDN with a boolean value. + ("BoolPM" 1) + ;; Compare the CDN with a natural value. + ("NatPM" 1) + ;; Compare the CDN with an integer value. + ("IntPM" 1) + ;; Compare the CDN with a fractional value. + ("FracPM" 1) + ;; Compare the CDN with a real value. + ("RealPM" 1) + ;; Compare the CDN with a character value. + ("CharPM" 1) + ;; Compare the CDN with a text value. + ("TextPM" 1) + ;; Compare the CDN with a variant value. If valid, proceed to test + ;; the variant's inner value. + ("VariantPM" 1) + ;; Access a tuple value at a given index, for further examination. + ("TuplePM" 1) + ;; Creates an instance of the backtracking info, as a preparatory + ;; step to exploring one of the branching paths. + ("AltPM" 2) + ;; Allows to test the CDN, while keeping a copy of it for more + ;; tasting later on. + ;; If necessary when doing multiple tests on a single value, like + ;; when testing multiple parts of a tuple. + ("SeqPM" 2) + ;; This is the jumping-off point for the PM part, where the PM + ;; data-structure is thrown away and the program jumps to the + ;; branch's body. + ("ExecPM" 1)) + +(defn de-meta + "(-> Optimized Optimized)" + [optim] + (|let [[meta optim-] optim] + (|case optim- + ($variant idx is-last? value) + ($variant idx is-last? (de-meta value)) + + ($tuple elems) + ($tuple (&/|map de-meta elems)) + + ($case value [_pm _bodies]) + ($case (de-meta value) + (&/T [_pm (&/|map de-meta _bodies)])) + + ($function _register-offset arity scope captured body*) + ($function _register-offset + arity + scope + (&/|map (fn [capture] + (|let [[_name [_meta ($captured _scope _idx _source)]] capture] + (&/T [_name ($captured _scope _idx (de-meta _source))]))) + captured) + (de-meta body*)) + + ($ann value-expr type-expr) + (de-meta value-expr) + + ($apply func args) + ($apply (de-meta func) + (&/|map de-meta args)) + + ($captured scope idx source) + ($captured scope idx (de-meta source)) + + ($proc proc-ident args special-args) + ($proc proc-ident (&/|map de-meta args) special-args) + + ($loop _register-offset _inits _body) + ($loop _register-offset + (&/|map de-meta _inits) + (de-meta _body)) + + ($iter _iter-register-offset args) + ($iter _iter-register-offset + (&/|map de-meta args)) + + ($let _value _register _body) + ($let (de-meta _value) + _register + (de-meta _body)) + + ($record-get _value _path) + ($record-get (de-meta _value) + _path) + + ($if _test _then _else) + ($if (de-meta _test) + (de-meta _then) + (de-meta _else)) + + _ + optim- + ))) + +;; This function does a simple transformation from the declarative +;; model of PM of the analyser, to the operational model of PM of the +;; optimizer. +;; You may notice that all branches end in PopPM. +;; The reason is that testing does not immediately imply throwing away +;; the data to be tested, which is why a popping step must immediately follow. +(defn ^:private transform-pm* [test] + (|case test + (&a-case/$NoTestAC) + (&/|list $PopPM) + + (&a-case/$StoreTestAC _register) + (&/|list ($BindPM _register)) + + (&a-case/$BoolTestAC _value) + (&/|list ($BoolPM _value) + $PopPM) + + (&a-case/$NatTestAC _value) + (&/|list ($NatPM _value) + $PopPM) + + (&a-case/$IntTestAC _value) + (&/|list ($IntPM _value) + $PopPM) + + (&a-case/$FracTestAC _value) + (&/|list ($FracPM _value) + $PopPM) + + (&a-case/$RealTestAC _value) + (&/|list ($RealPM _value) + $PopPM) + + (&a-case/$CharTestAC _value) + (&/|list ($CharPM _value) + $PopPM) + + (&a-case/$TextTestAC _value) + (&/|list ($TextPM _value) + $PopPM) + + (&a-case/$VariantTestAC _idx _num-options _sub-test) + (&/|++ (&/|list ($VariantPM (if (= _idx (dec _num-options)) + (&/$Right _idx) + (&/$Left _idx)))) + (&/|++ (transform-pm* _sub-test) + (&/|list $PopPM))) + + (&a-case/$TupleTestAC _sub-tests) + (|case _sub-tests + ;; An empty tuple corresponds to unit, which can't be tested in + ;; any meaningful way, so it's just popped. + (&/$Nil) + (&/|list $PopPM) + + ;; A tuple of a single element is equivalent to the element + ;; itself, to the element's PM is generated. + (&/$Cons _only-test (&/$Nil)) + (transform-pm* _only-test) + + ;; Single tuple PM features the tests of each tuple member + ;; inlined, it's operational equivalent is interleaving the + ;; access to each tuple member, followed by the testing of said + ;; member. + ;; That is way each sequence of access+subtesting gets generated + ;; and later they all get concatenated. + _ + (|let [tuple-size (&/|length _sub-tests)] + (&/|++ (&/flat-map (fn [idx+test*] + (|let [[idx test*] idx+test*] + (&/$Cons ($TuplePM (if (< idx (dec tuple-size)) + (&/$Left idx) + (&/$Right idx))) + (transform-pm* test*)))) + (&/zip2 (&/|range tuple-size) + _sub-tests)) + (&/|list $PopPM)))))) + +;; It will be common for pattern-matching on a very nested +;; data-structure to require popping all the intermediate +;; data-structures that were visited once it's all done. +;; However, the PM infrastructure employs a single data-stack to keep +;; all data nodes in the trajectory, and that data-stack can just be +;; thrown again entirely, in just one step. +;; Because of that, any ending POPs prior to throwing away the +;; data-stack would be completely useless. +;; This function cleans them all up, to avoid wasteful computation later. +(defn ^:private clean-unnecessary-pops [steps] + (|case steps + (&/$Cons ($PopPM) _steps) + (clean-unnecessary-pops _steps) + + _ + steps)) + +;; This transforms a single branch of a PM tree into it's operational +;; equivalent, while also associating the PM of the branch with the +;; jump to the branch's body. +(defn ^:private transform-pm [test body-id] + (&/fold (fn [right left] ($SeqPM left right)) + ($ExecPM body-id) + (clean-unnecessary-pops (&/|reverse (transform-pm* test))))) + +(defn ^:private pattern->text [pattern] + (|case pattern + ($PopPM) + "$PopPM" + + ($BindPM _id) + (str "($BindPM " _id ")") + + ($BoolPM _value) + (str "($BoolPM " (pr-str _value) ")") + + ($NatPM _value) + (str "($NatPM " (pr-str _value) ")") + + ($IntPM _value) + (str "($IntPM " (pr-str _value) ")") + + ($FracPM _value) + (str "($FracPM " (pr-str _value) ")") + + ($RealPM _value) + (str "($RealPM " (pr-str _value) ")") + + ($CharPM _value) + (str "($CharPM " (pr-str _value) ")") + + ($TextPM _value) + (str "($TextPM " (pr-str _value) ")") + + ($TuplePM (&/$Left _idx)) + (str "($TuplePM L" _idx ")") + + ($TuplePM (&/$Right _idx)) + (str "($TuplePM R" _idx ")") + + ($VariantPM (&/$Left _idx)) + (str "($VariantPM L" _idx ")") + + ($VariantPM (&/$Right _idx)) + (str "($VariantPM R" _idx ")") + + ($SeqPM _left _right) + (str "($SeqPM " (pattern->text _left) " " (pattern->text _right) ")") + + ($ExecPM _idx) + (str "($ExecPM " _idx ")") + + ;; $AltPM is not considered because it's not supposed to be + ;; present anywhere at this point in time. + )) + +;; This function fuses together the paths of the PM traversal, adding +;; branching AltPMs where necessary, and fusing similar paths together +;; as much as possible, when early parts of them coincide. +;; The goal is to minimize rework as much as possible by sharing as +;; much of each path as possible. +(defn ^:private fuse-pms [pre post] + (|case (&/T [pre post]) + [($PopPM) ($PopPM)] + $PopPM + + [($BindPM _pre-var-id) ($BindPM _post-var-id)] + (if (= _pre-var-id _post-var-id) + ($BindPM _pre-var-id) + ($AltPM pre post)) + + [($BoolPM _pre-value) ($BoolPM _post-value)] + (if (= _pre-value _post-value) + ($BoolPM _pre-value) + ($AltPM pre post)) + + [($NatPM _pre-value) ($NatPM _post-value)] + (if (= _pre-value _post-value) + ($NatPM _pre-value) + ($AltPM pre post)) + + [($IntPM _pre-value) ($IntPM _post-value)] + (if (= _pre-value _post-value) + ($IntPM _pre-value) + ($AltPM pre post)) + + [($FracPM _pre-value) ($FracPM _post-value)] + (if (= _pre-value _post-value) + ($FracPM _pre-value) + ($AltPM pre post)) + + [($RealPM _pre-value) ($RealPM _post-value)] + (if (= _pre-value _post-value) + ($RealPM _pre-value) + ($AltPM pre post)) + + [($CharPM _pre-value) ($CharPM _post-value)] + (if (= _pre-value _post-value) + ($CharPM _pre-value) + ($AltPM pre post)) + + [($TextPM _pre-value) ($TextPM _post-value)] + (if (= _pre-value _post-value) + ($TextPM _pre-value) + ($AltPM pre post)) + + [($TuplePM (&/$Left _pre-idx)) ($TuplePM (&/$Left _post-idx))] + (if (= _pre-idx _post-idx) + ($TuplePM (&/$Left _pre-idx)) + ($AltPM pre post)) + + [($TuplePM (&/$Right _pre-idx)) ($TuplePM (&/$Right _post-idx))] + (if (= _pre-idx _post-idx) + ($TuplePM (&/$Right _pre-idx)) + ($AltPM pre post)) + + [($VariantPM (&/$Left _pre-idx)) ($VariantPM (&/$Left _post-idx))] + (if (= _pre-idx _post-idx) + ($VariantPM (&/$Left _pre-idx)) + ($AltPM pre post)) + + [($VariantPM (&/$Right _pre-idx)) ($VariantPM (&/$Right _post-idx))] + (if (= _pre-idx _post-idx) + ($VariantPM (&/$Right _pre-idx)) + ($AltPM pre post)) + + [($SeqPM _pre-pre _pre-post) ($SeqPM _post-pre _post-post)] + (|case (fuse-pms _pre-pre _post-pre) + ($AltPM _ _) + ($AltPM pre post) + + fused-pre + ($SeqPM fused-pre (fuse-pms _pre-post _post-post))) + + _ + ($AltPM pre post) + )) + +(defn ^:private pattern-vars [pattern] + (|case pattern + ($BindPM _id) + (&/|list (&/T [_id false])) + + ($SeqPM _left _right) + (&/|++ (pattern-vars _left) (pattern-vars _right)) + + _ + (&/|list) + + ;; $AltPM is not considered because it's not supposed to be + ;; present anywhere at this point in time. + )) + +(defn ^:private find-unused-vars [var-table body] + (|let [[meta body-] body] + (|case body- + ($var (&/$Local _idx)) + (&/|update _idx (fn [_] true) var-table) + + ($captured _scope _c-idx [_ ($var (&/$Local _idx))]) + (&/|update _idx (fn [_] true) var-table) + + ($variant _idx _is-last? _value) + (find-unused-vars var-table _value) + + ($tuple _elems) + (&/fold find-unused-vars var-table _elems) + + ($ann _value-expr _type-expr) + (find-unused-vars var-table _value-expr) + + ($apply _func _args) + (&/fold find-unused-vars + (find-unused-vars var-table _func) + _args) + + ($proc _proc-ident _args _special-args) + (&/fold find-unused-vars var-table _args) + + ($loop _register-offset _inits _body) + (&/|++ (&/fold find-unused-vars var-table _inits) + (find-unused-vars var-table _body)) + + ($iter _ _args) + (&/fold find-unused-vars var-table _args) + + ($let _value _register _body) + (-> var-table + (find-unused-vars _value) + (find-unused-vars _body)) + + ($record-get _value _path) + (find-unused-vars var-table _value) + + ($if _test _then _else) + (-> var-table + (find-unused-vars _test) + (find-unused-vars _then) + (find-unused-vars _else)) + + ($case _value [_pm _bodies]) + (&/fold find-unused-vars + (find-unused-vars var-table _value) + _bodies) + + ($function _ _ _ _captured _) + (->> _captured + (&/|map &/|second) + (&/fold find-unused-vars var-table)) + + _ + var-table + ))) + +(defn ^:private clean-unused-pattern-registers [var-table pattern] + (|case pattern + ($BindPM _idx) + (|let [_new-idx (&/|get _idx var-table)] + (cond (= _idx _new-idx) + pattern + + (>= _new-idx 0) + ($BindPM _new-idx) + + :else + $PopPM)) + + ($SeqPM _left _right) + ($SeqPM (clean-unused-pattern-registers var-table _left) + (clean-unused-pattern-registers var-table _right)) + + _ + pattern + + ;; $AltPM is not considered because it's not supposed to be + ;; present anywhere at this point in time. + )) + +;; This function assumes that the var-table has an ascending index +;; order. +;; For example: (2 3 4 5 6 7 8), instead of (8 7 6 5 4 3 2) +(defn ^:private adjust-register-indexes* [offset var-table] + (|case var-table + (&/$Nil) + (&/|list) + + (&/$Cons [_idx _used?] _tail) + (if _used? + (&/$Cons (&/T [_idx (- _idx offset)]) + (adjust-register-indexes* offset _tail)) + (&/$Cons (&/T [_idx -1]) + (adjust-register-indexes* (inc offset) _tail)) + ))) + +(defn ^:private adjust-register-indexes [var-table] + (adjust-register-indexes* 0 var-table)) + +(defn ^:private clean-unused-body-registers [var-table body] + (|let [[meta body-] body] + (|case body- + ($var (&/$Local _idx)) + (|let [new-idx (or (&/|get _idx var-table) + _idx)] + (&/T [meta ($var (&/$Local new-idx))])) + + ($captured _scope _c-idx [_sub-meta ($var (&/$Local _idx))]) + (|let [new-idx (or (&/|get _idx var-table) + _idx)] + (&/T [meta ($captured _scope _c-idx (&/T [_sub-meta ($var (&/$Local new-idx))]))])) + + ($variant _idx _is-last? _value) + (&/T [meta ($variant _idx _is-last? (clean-unused-body-registers var-table _value))]) + + ($tuple _elems) + (&/T [meta ($tuple (&/|map (partial clean-unused-body-registers var-table) + _elems))]) + + ($ann _value-expr _type-expr) + (&/T [meta ($ann (clean-unused-body-registers var-table _value-expr) _type-expr)]) + + ($apply _func _args) + (&/T [meta ($apply (clean-unused-body-registers var-table _func) + (&/|map (partial clean-unused-body-registers var-table) + _args))]) + + ($proc _proc-ident _args _special-args) + (&/T [meta ($proc _proc-ident + (&/|map (partial clean-unused-body-registers var-table) + _args) + _special-args)]) + + ($loop _register-offset _inits _body) + (&/T [meta ($loop _register-offset + (&/|map (partial clean-unused-body-registers var-table) + _inits) + (clean-unused-body-registers var-table _body))]) + + ($iter _iter-register-offset _args) + (&/T [meta ($iter _iter-register-offset + (&/|map (partial clean-unused-body-registers var-table) + _args))]) + + ($let _value _register _body) + (&/T [meta ($let (clean-unused-body-registers var-table _value) + _register + (clean-unused-body-registers var-table _body))]) + + ($record-get _value _path) + (&/T [meta ($record-get (clean-unused-body-registers var-table _value) + _path)]) + + ($if _test _then _else) + (&/T [meta ($if (clean-unused-body-registers var-table _test) + (clean-unused-body-registers var-table _then) + (clean-unused-body-registers var-table _else))]) + + ($case _value [_pm _bodies]) + (&/T [meta ($case (clean-unused-body-registers var-table _value) + (&/T [_pm + (&/|map (partial clean-unused-body-registers var-table) + _bodies)]))]) + + ($function _register-offset _arity _scope _captured _body) + (&/T [meta ($function _register-offset + _arity + _scope + (&/|map (fn [capture] + (|let [[_name __var] capture] + (&/T [_name (clean-unused-body-registers var-table __var)]))) + _captured) + _body)]) + + _ + body + ))) + +(defn ^:private simplify-pattern [pattern] + (|case pattern + ($SeqPM ($TuplePM _idx) ($SeqPM ($PopPM) pattern*)) + (simplify-pattern pattern*) + + ($SeqPM ($TuplePM _idx) _right) + (|case (simplify-pattern _right) + ($SeqPM ($PopPM) pattern*) + pattern* + + _right* + ($SeqPM ($TuplePM _idx) _right*)) + + ($SeqPM _left _right) + ($SeqPM _left (simplify-pattern _right)) + + _ + pattern)) + +(defn ^:private optimize-register-use [pattern body] + (|let [p-vars (pattern-vars pattern) + p-vars* (find-unused-vars p-vars body) + adjusted-vars (adjust-register-indexes p-vars*) + clean-pattern (clean-unused-pattern-registers adjusted-vars pattern) + simple-pattern (simplify-pattern clean-pattern) + clean-body (clean-unused-body-registers adjusted-vars body)] + (&/T [simple-pattern clean-body]))) + +;; This is the top-level function for optimizing PM, which transforms +;; each branch and then fuses them together. +(defn ^:private optimize-pm [branches] + (|let [;; branches (&/|reverse branches*) + pms+bodies (&/map2 (fn [branch _body-id] + (|let [[_pattern _body] branch] + (optimize-register-use (transform-pm _pattern _body-id) + _body))) + branches + (&/|range (&/|length branches))) + pms (&/|map &/|first pms+bodies) + bodies (&/|map &/|second pms+bodies)] + (|case (&/|reverse pms) + (&/$Nil) + (assert false) + + (&/$Cons _head-pm _tail-pms) + (&/T [(&/fold fuse-pms _head-pm _tail-pms) + bodies]) + ))) + +;; [[Function-Folding Optimization]] + +;; The semantics of Lux establish that all functions are of a single +;; argument and the multi-argument functions are actually nested +;; functions being generated and then applied. +;; This, of course, would generate a lot of waste. +;; To avoid it, Lux actually folds function definitions together, +;; thereby creating functions that can be used both +;; one-argument-at-a-time, and also being called with all, or just a +;; partial amount of their arguments. +;; This avoids generating too many artifacts during compilation, since +;; they get "compressed", and it can also lead to faster execution, by +;; enabling optimized function calls later. + +;; Functions and captured variables have "scopes", which tell which +;; function they are, or to which function they belong. +;; During the folding, inner functions dissapear, since their bodies +;; are merged into their outer "parent" functions. +;; Their scopes must change accordingy. +(defn ^:private de-scope + "(-> Scope Scope Scope Scope)" + [old-scope new-scope scope] + (if (identical? new-scope scope) + old-scope + scope)) + +;; Also, it must be noted that when folding functions, the indexes of +;; the registers have to be changed accodingly. +;; That is what the following "shifting" functions are for. + +;; Shifts the registers for PM operations. +(defn ^:private shift-pattern [pattern] + (|case pattern + ($BindPM _var-id) + ($BindPM (inc _var-id)) + + ($SeqPM _left-pm _right-pm) + ($SeqPM (shift-pattern _left-pm) (shift-pattern _right-pm)) + + ($AltPM _left-pm _right-pm) + ($AltPM (shift-pattern _left-pm) (shift-pattern _right-pm)) + + _ + pattern + )) + +;; Shifts the body of a function after a folding is performed. +(defn shift-function-body + "(-> Scope Scope Bool Optimized Optimized)" + [old-scope new-scope own-body? body] + (|let [[meta body-] body] + (|case body- + ($variant idx is-last? value) + (&/T [meta ($variant idx is-last? (shift-function-body old-scope new-scope own-body? value))]) + + ($tuple elems) + (&/T [meta ($tuple (&/|map (partial shift-function-body old-scope new-scope own-body?) elems))]) + + ($case value [_pm _bodies]) + (&/T [meta ($case (shift-function-body old-scope new-scope own-body? value) + (&/T [(if own-body? + (shift-pattern _pm) + _pm) + (&/|map (partial shift-function-body old-scope new-scope own-body?) _bodies)]))]) + + ($function _register-offset arity scope captured body*) + (|let [scope* (de-scope old-scope new-scope scope)] + (&/T [meta ($function _register-offset + arity + scope* + (&/|map (fn [capture] + (|let [[_name [_meta ($captured _scope _idx _source)]] capture] + (&/T [_name (&/T [_meta ($captured scope* _idx (shift-function-body old-scope new-scope own-body? _source))])]))) + captured) + (shift-function-body old-scope new-scope false body*))])) + + ($ann value-expr type-expr) + (&/T [meta ($ann (shift-function-body old-scope new-scope own-body? value-expr) + type-expr)]) + + ($var var-kind) + (if own-body? + (|case var-kind + (&/$Local 0) + (&/T [meta ($apply body + (&/|list [meta ($var (&/$Local 1))]))]) + + (&/$Local idx) + (&/T [meta ($var (&/$Local (inc idx)))]) + + (&/$Global ?module ?name) + body) + body) + + ;; This special "apply" rule is for handling recursive calls better. + ($apply [meta-0 ($var (&/$Local 0))] args) + (if own-body? + (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))]) + (&/$Cons (&/T [meta-0 ($var (&/$Local 1))]) + (&/|map (partial shift-function-body old-scope new-scope own-body?) args)))]) + (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))]) + (&/|map (partial shift-function-body old-scope new-scope own-body?) args))])) + + ($apply func args) + (&/T [meta ($apply (shift-function-body old-scope new-scope own-body? func) + (&/|map (partial shift-function-body old-scope new-scope own-body?) args))]) + + ($captured scope idx source) + (if own-body? + source + (|case scope + (&/$Cons _ (&/$Cons _ (&/$Nil))) + source + + _ + (&/T [meta ($captured (de-scope old-scope new-scope scope) idx (shift-function-body old-scope new-scope own-body? source))]))) + + ($proc proc-ident args special-args) + (&/T [meta ($proc proc-ident (&/|map (partial shift-function-body old-scope new-scope own-body?) args) special-args)]) + + ($loop _register-offset _inits _body) + (&/T [meta ($loop (if own-body? + (inc _register-offset) + _register-offset) + (&/|map (partial shift-function-body old-scope new-scope own-body?) + _inits) + (shift-function-body old-scope new-scope own-body? _body))]) + + ($iter _iter-register-offset args) + (&/T [meta ($iter (if own-body? + (inc _iter-register-offset) + _iter-register-offset) + (&/|map (partial shift-function-body old-scope new-scope own-body?) args))]) + + ($let _value _register _body) + (&/T [meta ($let (shift-function-body old-scope new-scope own-body? _value) + (if own-body? + (inc _register) + _register) + (shift-function-body old-scope new-scope own-body? _body))]) + + ($record-get _value _path) + (&/T [meta ($record-get (shift-function-body old-scope new-scope own-body? _value) + _path)]) + + ($if _test _then _else) + (&/T [meta ($if (shift-function-body old-scope new-scope own-body? _test) + (shift-function-body old-scope new-scope own-body? _then) + (shift-function-body old-scope new-scope own-body? _else))]) + + _ + body + ))) + +;; [[Record-Manipulation Optimizations]] + +;; If a pattern-matching tree with a single branch is found, and that +;; branch corresponds to a tuple PM, and the body corresponds to a +;; local variable, it's likely that the local refers to some member of +;; the tuple that is being extracted. +;; That is the pattern that is to be expected of record read-access, +;; so this function tries to extract the (possibly nested) path +;; necessary, ending in the data-node of the wanted member. +(defn ^:private record-read-path + "(-> (List PM) Idx (List Idx))" + [pms member-idx] + (loop [current-idx 0 + pms pms] + (|case pms + (&/$Nil) + &/$None + + (&/$Cons _pm _pms) + (|case _pm + (&a-case/$NoTestAC) + (recur (inc current-idx) + _pms) + + (&a-case/$StoreTestAC _register) + (if (= member-idx _register) + (&/|list (&/T [current-idx (&/|empty? _pms)])) + (recur (inc current-idx) + _pms)) + + (&a-case/$TupleTestAC _sub-tests) + (let [sub-path (record-read-path _sub-tests member-idx)] + (if (not (&/|empty? sub-path)) + (&/$Cons (&/T [current-idx (&/|empty? _pms)]) sub-path) + (recur (inc current-idx) + _pms) + )) + + _ + (&/|list)) + ))) + +;; [[Loop Optimizations]] + +;; Lux doesn't offer any looping constructs, relying instead on +;; recursion. +;; Some common usages of recursion can be written more efficiently +;; just using regular loops/iteration. +;; This optimization looks for tail-calls in the function body, +;; rewriting them as jumps to the beginning of the function, while +;; they also updated the necessary local variables for the next iteration. +(defn ^:private optimize-iter + "(-> Int Optimized Optimized)" + [arity optim] + (|let [[meta optim-] optim] + (|case optim- + ($apply [meta-0 ($var (&/$Local 0))] _args) + (if (= arity (&/|length _args)) + (&/T [meta ($iter 1 _args)]) + optim) + + ($case _value [_pattern _bodies]) + (&/T [meta ($case _value + (&/T [_pattern + (&/|map (partial optimize-iter arity) + _bodies)]))]) + + ($let _value _register _body) + (&/T [meta ($let _value _register (optimize-iter arity _body))]) + + ($if _test _then _else) + (&/T [meta ($if _test + (optimize-iter arity _then) + (optimize-iter arity _else))]) + + ($ann _value-expr _type-expr) + (&/T [meta ($ann (optimize-iter arity _value-expr) _type-expr)]) + + _ + optim + ))) + +(defn ^:private contains-self-reference? + "(-> Optimized Bool)" + [body] + (|let [[meta body-] body + stepwise-test (fn [base arg] (or base (contains-self-reference? arg)))] + (|case body- + ($variant idx is-last? value) + (contains-self-reference? value) + + ($tuple elems) + (&/fold stepwise-test false elems) + + ($case value [_pm _bodies]) + (or (contains-self-reference? value) + (&/fold stepwise-test false _bodies)) + + ($function _ _ _ captured _) + (->> captured + (&/|map (fn [capture] + (|let [[_name [_meta ($captured _scope _idx _source)]] capture] + _source))) + (&/fold stepwise-test false)) + + ($ann value-expr type-expr) + (contains-self-reference? value-expr) + + ($var (&/$Local 0)) + true + + ($apply func args) + (or (contains-self-reference? func) + (&/fold stepwise-test false args)) + + ($proc proc-ident args special-args) + (&/fold stepwise-test false args) + + ($loop _register-offset _inits _body) + (or (&/fold stepwise-test false _inits) + (contains-self-reference? _body)) + + ($iter _ args) + (&/fold stepwise-test false args) + + ($let _value _register _body) + (or (contains-self-reference? _value) + (contains-self-reference? _body)) + + ($record-get _value _path) + (contains-self-reference? _value) + + ($if _test _then _else) + (or (contains-self-reference? _test) + (contains-self-reference? _then) + (contains-self-reference? _else)) + + _ + false + ))) + +(defn ^:private pm-loop-transform [register-offset direct? pattern] + (|case pattern + ($BindPM _var-id) + ($BindPM (+ register-offset (if direct? + (- _var-id 2) + (- _var-id 1)))) + + ($SeqPM _left-pm _right-pm) + ($SeqPM (pm-loop-transform register-offset direct? _left-pm) + (pm-loop-transform register-offset direct? _right-pm)) + + ($AltPM _left-pm _right-pm) + ($AltPM (pm-loop-transform register-offset direct? _left-pm) + (pm-loop-transform register-offset direct? _right-pm)) + + _ + pattern + )) + +;; This function must be run STRICTLY before shift-function body, as +;; the transformation assumes that SFB will be invoke after it. +(defn ^:private loop-transform [register-offset direct? body] + (|let [adjust-direct (fn [register] + ;; The register must be decreased once, since + ;; it will be re-increased in + ;; shift-function-body. + ;; The decrease is meant to keep things stable. + (if direct? + ;; And, if this adjustment is done + ;; directly during a loop-transform (and + ;; not indirectly if transforming an inner + ;; loop), then it must be decreased again + ;; because the 0/self var will no longer + ;; exist in the loop's context. + (- register 2) + (- register 1))) + [meta body-] body] + (|case body- + ($variant idx is-last? value) + (&/T [meta ($variant idx is-last? (loop-transform register-offset direct? value))]) + + ($tuple elems) + (&/T [meta ($tuple (&/|map (partial loop-transform register-offset direct?) elems))]) + + ($case value [_pm _bodies]) + (&/T [meta ($case (loop-transform register-offset direct? value) + (&/T [(pm-loop-transform register-offset direct? _pm) + (&/|map (partial loop-transform register-offset direct?) + _bodies)]))]) + + ;; Functions are ignored because they'll be handled properly at shift-function-body + + ($ann value-expr type-expr) + (&/T [meta ($ann (loop-transform register-offset direct? value-expr) + type-expr)]) + + ($var (&/$Local idx)) + ;; The index must be decreased once, because the var index is + ;; 1-based (since 0 is reserved for self-reference). + ;; Then it must be decreased again, since it will be increased + ;; in the shift-function-body call. + ;; Then, I add the offset to ensure the var points to the right register. + (&/T [meta ($var (&/$Local (-> (adjust-direct idx) + (+ register-offset))))]) + + ($apply func args) + (&/T [meta ($apply (loop-transform register-offset direct? func) + (&/|map (partial loop-transform register-offset direct?) args))]) + + ;; Captured-vars are ignored because they'll be handled properly at shift-function-body + + ($proc proc-ident args special-args) + (&/T [meta ($proc proc-ident (&/|map (partial loop-transform register-offset direct?) args) special-args)]) + + ($loop _register-offset _inits _body) + (&/T [meta ($loop (+ register-offset (adjust-direct _register-offset)) + (&/|map (partial loop-transform register-offset direct?) _inits) + (loop-transform register-offset direct? _body))]) + + ($iter _iter-register-offset args) + (&/T [meta ($iter (+ register-offset (adjust-direct _iter-register-offset)) + (&/|map (partial loop-transform register-offset direct?) args))]) + + ($let _value _register _body) + (&/T [meta ($let (loop-transform register-offset direct? _value) + (+ register-offset (adjust-direct _register)) + (loop-transform register-offset direct? _body))]) + + ($record-get _value _path) + (&/T [meta ($record-get (loop-transform register-offset direct? _value) + _path)]) + + ($if _test _then _else) + (&/T [meta ($if (loop-transform register-offset direct? _test) + (loop-transform register-offset direct? _then) + (loop-transform register-offset direct? _else))]) + + _ + body + ))) + +(defn ^:private inline-loop [meta register-offset scope captured args body] + (->> body + (loop-transform register-offset true) + (shift-function-body scope (&/|tail scope) true) + ($loop register-offset args) + (list meta) + (&/T))) + +;; [[Initial Optimization]] + +;; Before any big optimization can be done, the incoming Analysis nodes +;; must be transformed into Optimized nodes, amenable to further transformations. +;; This function does the job, while also detecting (and optimizing) +;; some simple surface patterns it may encounter. +(let [optimize-closure (fn [optimize closure] + (&/|map (fn [capture] + (|let [[_name _analysis] capture] + (&/T [_name (optimize _analysis)]))) + closure))] + (defn ^:private pass-0 + "(-> Bool Analysis Optimized)" + [top-level-func? analysis] + (|let [[meta analysis-] analysis] + (|case analysis- + (&a/$bool value) + (&/T [meta ($bool value)]) + + (&a/$nat value) + (&/T [meta ($nat value)]) + + (&a/$int value) + (&/T [meta ($int value)]) + + (&a/$frac value) + (&/T [meta ($frac value)]) + + (&a/$real value) + (&/T [meta ($real value)]) + + (&a/$char value) + (&/T [meta ($char value)]) + + (&a/$text value) + (&/T [meta ($text value)]) + + (&a/$variant idx is-last? value) + (&/T [meta ($variant idx is-last? (pass-0 top-level-func? value))]) + + (&a/$tuple elems) + (&/T [meta ($tuple (&/|map (partial pass-0 top-level-func?) elems))]) + + (&a/$apply func args) + (|let [=func (pass-0 top-level-func? func) + =args (&/|map (partial pass-0 top-level-func?) args)] + (|case =func + [_ ($ann [_ ($function _register-offset _arity _scope _captured _body)] + _)] + (if (and (= _arity (&/|length =args)) + (not (contains-self-reference? _body))) + (inline-loop meta _register-offset _scope _captured =args _body) + (&/T [meta ($apply =func =args)])) + + _ + (&/T [meta ($apply =func =args)]))) + + (&a/$case value branches) + (let [normal-case-optim (fn [] + (&/T [meta ($case (pass-0 top-level-func? value) + (optimize-pm (&/|map (fn [branch] + (|let [[_pattern _body] branch] + (&/T [_pattern (pass-0 top-level-func? _body)]))) + branches)))]))] + (|case branches + ;; The pattern for a let-expression is a single branch, + ;; tying the value to a register. + (&/$Cons [(&a-case/$StoreTestAC _register) _body] (&/$Nil)) + (&/T [meta ($let (pass-0 top-level-func? value) _register (pass-0 top-level-func? _body))]) + + (&/$Cons [(&a-case/$BoolTestAC false) _else] + (&/$Cons [(&a-case/$BoolTestAC true) _then] + (&/$Nil))) + (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) + + ;; The pattern for a record-get is a single branch, with a + ;; tuple pattern and a body corresponding to a + ;; local-variable extracted from the tuple. + (&/$Cons [(&a-case/$TupleTestAC _sub-tests) [_ (&a/$var (&/$Local _member-idx))]] (&/$Nil)) + (|let [_path (record-read-path _sub-tests _member-idx)] + (if (&/|empty? _path) + ;; If the path is empty, that means it was a + ;; false-positive and normal PM optimization should be + ;; done instead. + (normal-case-optim) + ;; Otherwise, we've got ourselves a record-get expression. + (&/T [meta ($record-get (pass-0 top-level-func? value) _path)]))) + + ;; If no special patterns are found, just do normal PM optimization. + _ + (normal-case-optim))) + + (&a/$lambda _register-offset scope captured body) + (|let [inner-func? (|case body + [_ (&a/$lambda _ _ _ _)] + true + + _ + false)] + (|case (pass-0 (not inner-func?) body) + ;; If the body of a function is another function, that means + ;; no work was done in-between and both layers can be folded + ;; into one. + [_ ($function _ _arity _scope _captured _body)] + (|let [new-arity (inc _arity) + collapsed-body (shift-function-body scope _scope true _body)] + (&/T [meta ($function _register-offset + new-arity + scope + (optimize-closure (partial pass-0 top-level-func?) captured) + (if top-level-func? + (optimize-iter new-arity collapsed-body) + collapsed-body))])) + + ;; Otherwise, they're nothing to be done and we've got a + ;; 1-arity function. + =body + (&/T [meta ($function _register-offset + 1 scope + (optimize-closure (partial pass-0 top-level-func?) captured) + (if top-level-func? + (optimize-iter 1 =body) + =body))]))) + + (&a/$ann value-expr type-expr) + (&/T [meta ($ann (pass-0 top-level-func? value-expr) type-expr)]) + + (&a/$var var-kind) + (&/T [meta ($var var-kind)]) + + (&a/$captured scope idx source) + (&/T [meta ($captured scope idx (pass-0 top-level-func? source))]) + + (&a/$proc proc-ident args special-args) + (&/T [meta ($proc proc-ident (&/|map (partial pass-0 top-level-func?) args) special-args)]) + + _ + (assert false (prn-str 'pass-0 top-level-func? (&/adt->text analysis))) + )))) + +;; [Exports] +(defn optimize + "(-> Analysis Optimized)" + [analysis] + (->> analysis + (pass-0 true))) diff --git a/luxc/src/lux/parser.clj b/luxc/src/lux/parser.clj new file mode 100644 index 000000000..ceafcd92e --- /dev/null +++ b/luxc/src/lux/parser.clj @@ -0,0 +1,117 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.parser + (:require [clojure.template :refer [do-template]] + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return |case]] + [lexer :as &lexer]))) + +;; [Utils] +(def ^:private base-uneven-record-error + "[Parser Error] Records must have an even number of elements.") + +(defn ^:private repeat% [action] + (fn [state] + (|case (action state) + (&/$Left ^String error) + (cond (.contains error base-uneven-record-error) + (&/$Left error) + + (not (.contains error "[Parser Error]")) + (&/$Left error) + + :else + (&/$Right (&/T [state &/$Nil]))) + + (&/$Right state* head) + ((|do [tail (repeat% action)] + (return (&/$Cons head tail))) + state*)))) + +(do-template [ ] + (defn [parse] + (|do [elems (repeat% parse) + token &lexer/lex] + (|case token + [meta ( _)] + (return ( (&/fold &/|++ &/$Nil elems))) + + _ + (&/fail-with-loc (str "[Parser Error] Unbalanced " ".")) + ))) + + ^:private parse-form &lexer/$Close_Paren "parantheses" &/$FormS + ^:private parse-tuple &lexer/$Close_Bracket "brackets" &/$TupleS + ) + +(defn ^:private parse-record [parse] + (|do [elems* (repeat% parse) + token &lexer/lex + :let [elems (&/fold &/|++ &/$Nil elems*)]] + (|case token + [meta (&lexer/$Close_Brace _)] + (if (even? (&/|length elems)) + (return (&/$RecordS (&/|as-pairs elems))) + (&/fail-with-loc base-uneven-record-error)) + + _ + (&/fail-with-loc "[Parser Error] Unbalanced braces.") + ))) + +;; [Interface] +(def parse + (|do [token &lexer/lex + :let [[meta token*] token]] + (|case token* + (&lexer/$White_Space _) + (return &/$Nil) + + (&lexer/$Comment _) + (return &/$Nil) + + (&lexer/$Bool ?value) + (return (&/|list (&/T [meta (&/$BoolS (Boolean/parseBoolean ?value))]))) + + (&lexer/$Nat ?value) + (return (&/|list (&/T [meta (&/$NatS (Long/parseUnsignedLong ?value))]))) + + (&lexer/$Int ?value) + (return (&/|list (&/T [meta (&/$IntS (Long/parseLong ?value))]))) + + (&lexer/$Frac ?value) + (return (&/|list (&/T [meta (&/$FracS (&/decode-frac ?value))]))) + + (&lexer/$Real ?value) + (return (&/|list (&/T [meta (&/$RealS (Double/parseDouble ?value))]))) + + (&lexer/$Char ^String ?value) + (return (&/|list (&/T [meta (&/$CharS (.charAt ?value 0))]))) + + (&lexer/$Text ?value) + (return (&/|list (&/T [meta (&/$TextS ?value)]))) + + (&lexer/$Symbol ?ident) + (return (&/|list (&/T [meta (&/$SymbolS ?ident)]))) + + (&lexer/$Tag ?ident) + (return (&/|list (&/T [meta (&/$TagS ?ident)]))) + + (&lexer/$Open_Paren _) + (|do [syntax (parse-form parse)] + (return (&/|list (&/T [meta syntax])))) + + (&lexer/$Open_Bracket _) + (|do [syntax (parse-tuple parse)] + (return (&/|list (&/T [meta syntax])))) + + (&lexer/$Open_Brace _) + (|do [syntax (parse-record parse)] + (return (&/|list (&/T [meta syntax])))) + + _ + (&/fail-with-loc "[Parser Error] Unknown lexer token.") + ))) diff --git a/luxc/src/lux/reader.clj b/luxc/src/lux/reader.clj new file mode 100644 index 000000000..5a7734061 --- /dev/null +++ b/luxc/src/lux/reader.clj @@ -0,0 +1,141 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.reader + (:require [clojure.string :as string] + clojure.core.match + clojure.core.match.array + [lux.base :as & :refer [defvariant |do return* return fail* |let |case]])) + +;; [Tags] +(defvariant + ("No" 1) + ("Done" 1) + ("Yes" 2)) + +;; [Utils] +(defn ^:private with-line [body] + (fn [state] + (|case (&/get$ &/$source state) + (&/$Nil) + (fail* "[Reader Error] EOF") + + (&/$Cons [[file-name line-num column-num] line] + more) + (|case (body file-name line-num column-num line) + ($No msg) + ((&/fail-with-loc msg) state) + + ($Done output) + (return* (&/set$ &/$source more state) + output) + + ($Yes output line*) + (return* (&/set$ &/$source (&/$Cons line* more) state) + output)) + ))) + +(defn ^:private with-lines [body] + (fn [state] + (|case (body (&/get$ &/$source state)) + (&/$Right reader* match) + (return* (&/set$ &/$source reader* state) + match) + + (&/$Left msg) + ((&/fail-with-loc msg) state) + ))) + +(defn ^:private re-find! [^java.util.regex.Pattern regex column ^String line] + (let [matcher (doto (.matcher regex line) + (.region column (.length line)) + (.useAnchoringBounds true))] + (when (.find matcher) + (.group matcher 0)))) + +;; [Exports] +(defn read-regex [regex] + (with-line + (fn [file-name line-num column-num ^String line] + (if-let [^String match (re-find! regex column-num line)] + (let [match-length (.length match) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + ($Done (&/T [(&/T [file-name line-num column-num]) true match])) + ($Yes (&/T [(&/T [file-name line-num column-num]) false match]) + (&/T [(&/T [file-name line-num column-num*]) line])))) + ($No (str "[Reader Error] Pattern failed: " regex)))))) + +(defn read-regex+ [regex] + (with-lines + (fn [reader] + (loop [prefix "" + reader* reader] + (|case reader* + (&/$Nil) + (&/$Left "[Reader Error] EOF") + + (&/$Cons [[file-name line-num column-num] ^String line] + reader**) + (if-let [^String match (re-find! regex column-num line)] + (let [match-length (.length match) + column-num* (+ column-num match-length) + prefix* (if (= 0 column-num) + (str prefix "\n" match) + (str prefix match))] + (if (= column-num* (.length line)) + (recur prefix* reader**) + (&/$Right (&/T [(&/$Cons (&/T [(&/T [file-name line-num column-num*]) line]) + reader**) + (&/T [(&/T [file-name line-num column-num]) prefix*])])))) + (&/$Left (str "[Reader Error] Pattern failed: " regex)))))))) + +(defn read-text [^String text] + "(-> Text (Reader Text))" + (with-line + (fn [file-name line-num column-num ^String line] + (if (.startsWith line text column-num) + (let [match-length (.length text) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + ($Done (&/T [(&/T [file-name line-num column-num]) true text])) + ($Yes (&/T [(&/T [file-name line-num column-num]) false text]) + (&/T [(&/T [file-name line-num column-num*]) line])))) + ($No (str "[Reader Error] Text failed: " text)))))) + +(defn read-text? [^String text] + "(-> Text (Reader (Maybe Text)))" + (with-line + (fn [file-name line-num column-num ^String line] + (if (.startsWith line text column-num) + (let [match-length (.length text) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + ($Done (&/T [(&/T [file-name line-num column-num]) true (&/$Some text)])) + ($Yes (&/T [(&/T [file-name line-num column-num]) false (&/$Some text)]) + (&/T [(&/T [file-name line-num column-num*]) line])))) + ($Yes (&/T [(&/T [file-name line-num column-num]) false &/$None]) + (&/T [(&/T [file-name line-num column-num]) line])))))) + +(defn from [^String name ^String source-code] + (let [lines (string/split-lines source-code) + indexed-lines (map (fn [line line-num] + (&/T [(&/T [name (inc line-num) 0]) + line])) + lines + (range (count lines)))] + (reduce (fn [tail head] (&/$Cons head tail)) + &/$Nil + (reverse indexed-lines)))) + +(defn with-source [name content body] + (fn [state] + (|let [old-source (&/get$ &/$source state)] + (|case (body (&/set$ &/$source (from name content) state)) + (&/$Left error) + (&/$Left error) + + (&/$Right state* output) + (&/$Right (&/T [(&/set$ &/$source old-source state*) output])))))) diff --git a/luxc/src/lux/repl.clj b/luxc/src/lux/repl.clj new file mode 100644 index 000000000..195f3dc3e --- /dev/null +++ b/luxc/src/lux/repl.clj @@ -0,0 +1,89 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.repl + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]] + [type :as &type] + [analyser :as &analyser] + [optimizer :as &optimizer] + [compiler :as &compiler]) + [lux.compiler.cache :as &cache] + [lux.analyser.base :as &a-base] + [lux.analyser.lux :as &a-lux] + [lux.analyser.module :as &module]) + (:import (java.io InputStreamReader + BufferedReader))) + +;; [Utils] +(def ^:private repl-module "REPL") + +(defn ^:private repl-cursor [repl-line] + (&/T [repl-module repl-line 0])) + +(defn ^:private init [source-dirs] + (do (&compiler/init!) + (|case ((|do [_ (&compiler/compile-module source-dirs "lux") + _ (&cache/delete repl-module) + _ (&module/create-module repl-module 0) + _ (fn [?state] + (return* (&/set$ &/$source + (&/|list (&/T [(repl-cursor -1) "(;import lux)"])) + ?state) + nil)) + analysed-tokens (&analyser/repl-analyse &optimizer/optimize &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers) + eval-values (->> analysed-tokens (&/|map &optimizer/optimize) (&/map% &compiler/eval!))] + (return nil)) + (&/init-state &/$REPL)) + (&/$Right ?state _) + (do (println) + (println "Welcome to the REPL!") + (println "Type \"exit\" to leave.") + (println) + ?state) + + (&/$Left ?message) + (assert false ?message)) + )) + +;; [Values] +(defn repl [source-dirs] + (with-open [input (->> System/in (new InputStreamReader) (new BufferedReader))] + (loop [state (init source-dirs) + repl-line 0 + multi-line? false] + (let [_ (if (not multi-line?) + (.print System/out "> ") + (.print System/out " ")) + line (.readLine input)] + (if (= "exit" line) + (println "Till next time...") + (let [line* (&/|list (&/T [(repl-cursor repl-line) line])) + state* (&/update$ &/$source + (fn [_source] (&/|++ _source line*)) + state)] + (|case ((|do [analysed-tokens (&analyser/repl-analyse &optimizer/optimize &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers) + eval-values (->> analysed-tokens (&/|map &optimizer/optimize) (&/map% &compiler/eval!)) + :let [outputs (map (fn [analysis value] + (|let [[[_type _cursor] _term] analysis] + [_type value])) + (&/->seq analysed-tokens) + (&/->seq eval-values))]] + (return outputs)) + state*) + (&/$Right state** outputs) + (do (doseq [[_type _value] outputs] + (.println System/out (str "=> " (pr-str _value) "\n:: " (&type/show-type _type)"\n"))) + (recur state** (inc repl-line) false)) + + (&/$Left ^String ?message) + (if (or (= "[Reader Error] EOF" ?message) + (.contains ?message "[Parser Error] Unbalanced ")) + (recur state* (inc repl-line) true) + (do (println ?message) + (recur state (inc repl-line) false))) + )))) + ))) diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj new file mode 100644 index 000000000..d387053dc --- /dev/null +++ b/luxc/src/lux/type.clj @@ -0,0 +1,972 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.type + (:refer-clojure :exclude [deref apply merge bound?]) + (:require [clojure.template :refer [do-template]] + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]]) + [lux.type.host :as &&host])) + +(declare show-type + type=) + +;; [Utils] +(defn |list? [xs] + (|case xs + (&/$Nil) + true + + (&/$Cons x xs*) + (|list? xs*) + + _ + false)) + +(def empty-env &/$Nil) + +(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil))) +(def Nat (&/$NamedT (&/T ["lux" "Nat"]) (&/$HostT &&host/nat-data-tag &/$Nil))) +(def Frac (&/$NamedT (&/T ["lux" "Frac"]) (&/$HostT &&host/frac-data-tag &/$Nil))) +(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "java.lang.Long" &/$Nil))) +(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "java.lang.Double" &/$Nil))) +(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "java.lang.Character" &/$Nil))) +(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "java.lang.String" &/$Nil))) +(def Ident (&/$NamedT (&/T ["lux" "Ident"]) (&/$ProdT Text Text))) + +(def Bottom + (&/$NamedT (&/T ["lux" "Bottom"]) + (&/$UnivQ empty-env + (&/$BoundT 1)))) + +(def IO + (&/$NamedT (&/T ["lux/codata" "IO"]) + (&/$UnivQ empty-env + (&/$LambdaT &/$VoidT (&/$BoundT 1))))) + +(def List + (&/$NamedT (&/T ["lux" "List"]) + (&/$UnivQ empty-env + (&/$SumT + ;; lux;Nil + &/$UnitT + ;; lux;Cons + (&/$ProdT (&/$BoundT 1) + (&/$AppT (&/$BoundT 0) + (&/$BoundT 1))))))) + +(def Maybe + (&/$NamedT (&/T ["lux" "Maybe"]) + (&/$UnivQ empty-env + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1)) + ))) + +(def Type + (&/$NamedT (&/T ["lux" "Type"]) + (let [Type (&/$AppT (&/$BoundT 0) (&/$BoundT 1)) + TypeList (&/$AppT List Type) + TypePair (&/$ProdT Type Type)] + (&/$AppT (&/$UnivQ empty-env + (&/$SumT + ;; HostT + (&/$ProdT Text TypeList) + (&/$SumT + ;; VoidT + &/$UnitT + (&/$SumT + ;; UnitT + &/$UnitT + (&/$SumT + ;; SumT + TypePair + (&/$SumT + ;; ProdT + TypePair + (&/$SumT + ;; LambdaT + TypePair + (&/$SumT + ;; BoundT + Nat + (&/$SumT + ;; VarT + Nat + (&/$SumT + ;; ExT + Nat + (&/$SumT + ;; UnivQ + (&/$ProdT TypeList Type) + (&/$SumT + ;; ExQ + (&/$ProdT TypeList Type) + (&/$SumT + ;; AppT + TypePair + ;; NamedT + (&/$ProdT Ident Type))))))))))))) + ) + &/$VoidT)))) + +(def Ann-Value + (&/$NamedT (&/T ["lux" "Ann-Value"]) + (let [Ann-Value (&/$AppT (&/$BoundT 0) (&/$BoundT 1))] + (&/$AppT (&/$UnivQ empty-env + (&/$SumT + ;; BoolM + Bool + (&/$SumT + ;; NatM + Nat + (&/$SumT + ;; IntM + Int + (&/$SumT + ;; FracM + Frac + (&/$SumT + ;; RealM + Real + (&/$SumT + ;; CharM + Char + (&/$SumT + ;; TextM + Text + (&/$SumT + ;; IdentM + Ident + (&/$SumT + ;; ListM + (&/$AppT List Ann-Value) + ;; DictM + (&/$AppT List (&/$ProdT Text Ann-Value))))))))))) + ) + &/$VoidT)))) + +(def Anns + (&/$NamedT (&/T ["lux" "Anns"]) + (&/$AppT List (&/$ProdT Ident Ann-Value)))) + +(def Macro) + +(defn set-macro-type! [type] + (def Macro type) + nil) + +(defn bound? [id] + (fn [state] + (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (|case type + (&/$Some type*) + (return* state true) + + (&/$None) + (return* state false)) + (fail* (str "[Type Error] Unknown type-var: " id))))) + +(defn deref [id] + (fn [state] + (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (|case type* + (&/$Some type) + (return* state type) + + (&/$None) + (fail* (str "[Type Error] Unbound type-var: " id))) + (fail* (str "[Type Error] Unknown type-var: " id))))) + +(defn deref+ [type] + (|case type + (&/$VarT id) + (deref id) + + _ + (fail (str "[Type Error] Type is not a variable: " (show-type type))) + )) + +(defn set-var [id type] + (fn [state] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (|case tvar + (&/$Some bound) + (if (type= type bound) + (return* state nil) + (fail* (str "[Type Error] Can't re-bind type var: " id " | Current type: " (show-type bound)))) + + (&/$None) + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) + ts)) + state) + nil)) + (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) + +(defn reset-var [id type] + (fn [state] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) + ts)) + state) + nil) + (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) + +(defn unset-var [id] + (fn [state] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id &/$None %) + ts)) + state) + nil) + (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) + +;; [Exports] +;; Type vars +(def create-var + (fn [state] + (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [ms] (&/|put id &/$None ms)))) + state) + id)))) + +(def existential + ;; (Lux Type) + (|do [seed &/gen-id] + (return (&/$ExT seed)))) + +(declare clean*) +(defn delete-var [id] + (|do [? (bound? id) + _ (if ? + (return nil) + (|do [ex existential] + (set-var id ex)))] + (fn [state] + ((|do [mappings* (&/map% (fn [binding] + (|let [[?id ?type] binding] + (if (.equals ^Object id ?id) + (return binding) + (|case ?type + (&/$None) + (return binding) + + (&/$Some ?type*) + (|case ?type* + (&/$VarT ?id*) + (if (.equals ^Object id ?id*) + (return (&/T [?id &/$None])) + (return binding)) + + _ + (|do [?type** (clean* id ?type*)] + (return (&/T [?id (&/$Some ?type**)])))) + )))) + (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] + (fn [state] + (return* (&/update$ &/$type-vars #(&/set$ &/$mappings (&/|remove id mappings*) %) + state) + nil))) + state)))) + +(defn with-var [k] + (|do [id create-var + output (k (&/$VarT id)) + _ (delete-var id)] + (return output))) + +(defn clean* [?tid type] + (|case type + (&/$VarT ?id) + (if (.equals ^Object ?tid ?id) + (|do [? (bound? ?id)] + (if ? + (deref ?id) + (return type))) + (|do [? (bound? ?id)] + (if ? + (|do [=type (deref ?id) + ==type (clean* ?tid =type)] + (|case ==type + (&/$VarT =id) + (if (.equals ^Object ?tid =id) + (|do [_ (unset-var ?id)] + (return type)) + (|do [_ (reset-var ?id ==type)] + (return type))) + + _ + (|do [_ (reset-var ?id ==type)] + (return type)))) + (return type))) + ) + + (&/$HostT ?name ?params) + (|do [=params (&/map% (partial clean* ?tid) ?params)] + (return (&/$HostT ?name =params))) + + (&/$LambdaT ?arg ?return) + (|do [=arg (clean* ?tid ?arg) + =return (clean* ?tid ?return)] + (return (&/$LambdaT =arg =return))) + + (&/$AppT ?lambda ?param) + (|do [=lambda (clean* ?tid ?lambda) + =param (clean* ?tid ?param)] + (return (&/$AppT =lambda =param))) + + (&/$ProdT ?left ?right) + (|do [=left (clean* ?tid ?left) + =right (clean* ?tid ?right)] + (return (&/$ProdT =left =right))) + + (&/$SumT ?left ?right) + (|do [=left (clean* ?tid ?left) + =right (clean* ?tid ?right)] + (return (&/$SumT =left =right))) + + (&/$UnivQ ?env ?body) + (|do [=env (&/map% (partial clean* ?tid) ?env) + body* (clean* ?tid ?body)] ;; TODO: DON'T CLEAN THE BODY + (return (&/$UnivQ =env body*))) + + (&/$ExQ ?env ?body) + (|do [=env (&/map% (partial clean* ?tid) ?env) + body* (clean* ?tid ?body)] ;; TODO: DON'T CLEAN THE BODY + (return (&/$ExQ =env body*))) + + _ + (return type) + )) + +(defn clean [tvar type] + (|case tvar + (&/$VarT ?id) + (clean* ?id type) + + _ + (fail (str "[Type Error] Not type-var: " (show-type tvar))))) + +(defn ^:private unravel-fun [type] + (|case type + (&/$LambdaT ?in ?out) + (|let [[??out ?args] (unravel-fun ?out)] + (&/T [??out (&/$Cons ?in ?args)])) + + _ + (&/T [type &/$Nil]))) + +(defn ^:private unravel-app [fun-type] + (|case fun-type + (&/$AppT ?left ?right) + (|let [[?fun-type ?args] (unravel-app ?left)] + (&/T [?fun-type (&/|++ ?args (&/|list ?right))])) + + _ + (&/T [fun-type &/$Nil]))) + +(do-template [ ] + (do (defn [type] + "(-> Type (List Type))" + (|case type + ( left right) + (&/$Cons left ( right)) + + _ + (&/|list type))) + + (defn [tag type] + "(-> Int Type (Lux Type))" + (|case type + (&/$NamedT ?name ?type) + ( tag ?type) + + ( ?left ?right) + (|case (&/T [tag ?right]) + [0 _] (return ?left) + [1 ( ?left* _)] (return ?left*) + [1 _] (return ?right) + [_ ( _ _)] ( (dec tag) ?right) + _ (fail (str "[Type Error] " " lacks member: " tag " | " (show-type type)))) + + _ + (fail (str "[Type Error] Type is not a " ": " (show-type type)))))) + + &/$SumT flatten-sum sum-at "Sum" + &/$ProdT flatten-prod prod-at "Product" + ) + +(do-template [ ] + (defn [types] + "(-> (List Type) Type)" + (|case (&/|reverse types) + (&/$Cons last prevs) + (&/fold (fn [right left] ( left right)) last prevs) + + (&/$Nil) + )) + + Variant$ &/$SumT &/$VoidT + Tuple$ &/$ProdT &/$UnitT + ) + +(defn show-type [^objects type] + (|case type + (&/$HostT name params) + (|case params + (&/$Nil) + (str "(host " name ")") + + _ + (str "(host " name " " (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) + + (&/$VoidT) + "Void" + + (&/$UnitT) + "Unit" + + (&/$ProdT _) + (str "[" (->> (flatten-prod type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) "]") + + (&/$SumT _) + (str "(| " (->> (flatten-sum type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") + + (&/$LambdaT input output) + (|let [[?out ?ins] (unravel-fun type)] + (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) + + (&/$VarT id) + (str "⌈v:" id "⌋") + + (&/$ExT ?id) + (str "⟨e:" ?id "⟩") + + (&/$BoundT idx) + (str idx) + + (&/$AppT _ _) + (|let [[?call-fun ?call-args] (unravel-app type)] + (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) + + (&/$UnivQ ?env ?body) + (str "(All " (show-type ?body) ")") + + (&/$ExQ ?env ?body) + (str "(Ex " (show-type ?body) ")") + + (&/$NamedT ?name ?type) + (&/ident->text ?name) + + _ + (assert false (prn-str 'show-type (&/adt->text type))))) + +(defn type= [x y] + (or (clojure.lang.Util/identical x y) + (let [output (|case [x y] + [(&/$NamedT [?xmodule ?xname] ?xtype) (&/$NamedT [?ymodule ?yname] ?ytype)] + (and (= ?xmodule ?ymodule) + (= ?xname ?yname)) + + [(&/$HostT xname xparams) (&/$HostT yname yparams)] + (and (.equals ^Object xname yname) + (= (&/|length xparams) (&/|length yparams)) + (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams)) + + [(&/$VoidT) (&/$VoidT)] + true + + [(&/$UnitT) (&/$UnitT)] + true + + [(&/$ProdT xL xR) (&/$ProdT yL yR)] + (and (type= xL yL) + (type= xR yR)) + + [(&/$SumT xL xR) (&/$SumT yL yR)] + (and (type= xL yL) + (type= xR yR)) + + [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] + (and (type= xinput yinput) + (type= xoutput youtput)) + + [(&/$VarT xid) (&/$VarT yid)] + (.equals ^Object xid yid) + + [(&/$BoundT xidx) (&/$BoundT yidx)] + (= xidx yidx) + + [(&/$ExT xid) (&/$ExT yid)] + (.equals ^Object xid yid) + + [(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)] + (and (type= xlambda ylambda) (type= xparam yparam)) + + [(&/$UnivQ xenv xbody) (&/$UnivQ yenv ybody)] + (type= xbody ybody) + + [(&/$NamedT ?xname ?xtype) _] + (type= ?xtype y) + + [_ (&/$NamedT ?yname ?ytype)] + (type= x ?ytype) + + [_ _] + false + )] + output))) + +(defn ^:private fp-get [k fixpoints] + (|let [[e a] k] + (|case fixpoints + (&/$Nil) + &/$None + + (&/$Cons [[e* a*] v*] fixpoints*) + (if (and (type= e e*) + (type= a a*)) + (&/$Some v*) + (fp-get k fixpoints*)) + ))) + +(defn ^:private fp-put [k v fixpoints] + (&/$Cons (&/T [k v]) fixpoints)) + +(defn show-type+ [type] + (|case type + (&/$VarT ?id) + (fn [state] + (|case ((deref ?id) state) + (&/$Right state* bound) + (return* state (str (show-type type) " = " (show-type bound))) + + (&/$Left _) + (return* state (show-type type)))) + + _ + (return (show-type type)))) + +(defn ^:private check-error [err expected actual] + (|do [=expected (show-type+ expected) + =actual (show-type+ actual)] + (&/fail-with-loc (str (if (= "" err) err (str err "\n")) + "[Type Checker]\n" + "Expected: " =expected "\n\n" + "Actual: " =actual + "\n")))) + +(defn beta-reduce [env type] + (|case type + (&/$HostT ?name ?params) + (&/$HostT ?name (&/|map (partial beta-reduce env) ?params)) + + (&/$SumT ?left ?right) + (&/$SumT (beta-reduce env ?left) (beta-reduce env ?right)) + + (&/$ProdT ?left ?right) + (&/$ProdT (beta-reduce env ?left) (beta-reduce env ?right)) + + (&/$AppT ?type-fn ?type-arg) + (&/$AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) + + (&/$UnivQ ?local-env ?local-def) + (|case ?local-env + (&/$Nil) + (&/$UnivQ env ?local-def) + + _ + type) + + (&/$ExQ ?local-env ?local-def) + (|case ?local-env + (&/$Nil) + (&/$ExQ env ?local-def) + + _ + type) + + (&/$LambdaT ?input ?output) + (&/$LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) + + (&/$BoundT ?idx) + (|case (&/|at ?idx env) + (&/$Some bound) + (beta-reduce env bound) + + _ + (assert false (str "[Type Error] Unknown var: " ?idx " | " (&/->seq (&/|map show-type env))))) + + _ + type + )) + +(defn apply-type [type-fn param] + (|case type-fn + (&/$UnivQ local-env local-def) + (return (beta-reduce (->> local-env + (&/$Cons param) + (&/$Cons type-fn)) + local-def)) + + (&/$ExQ local-env local-def) + (return (beta-reduce (->> local-env + (&/$Cons param) + (&/$Cons type-fn)) + local-def)) + + (&/$AppT F A) + (|do [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + (&/$NamedT ?name ?type) + (apply-type ?type param) + + ;; TODO: This one must go... + (&/$ExT id) + (return (&/$AppT type-fn param)) + + (&/$VarT id) + (|do [=type-fun (deref id)] + (apply-type =type-fun param)) + + _ + (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) + +(def ^:private init-fixpoints &/$Nil) + +(defn ^:private check* [class-loader fixpoints invariant?? expected actual] + (if (clojure.lang.Util/identical expected actual) + (return fixpoints) + (&/with-attempt + (|case [expected actual] + [(&/$VarT ?eid) (&/$VarT ?aid)] + (if (.equals ^Object ?eid ?aid) + (return fixpoints) + (|do [ebound (fn [state] + (|case ((deref ?eid) state) + (&/$Right state* ebound) + (return* state* (&/$Some ebound)) + + (&/$Left _) + (return* state &/$None))) + abound (fn [state] + (|case ((deref ?aid) state) + (&/$Right state* abound) + (return* state* (&/$Some abound)) + + (&/$Left _) + (return* state &/$None)))] + (|case [ebound abound] + [(&/$None _) (&/$None _)] + (|do [_ (set-var ?eid actual)] + (return fixpoints)) + + [(&/$Some etype) (&/$None _)] + (check* class-loader fixpoints invariant?? etype actual) + + [(&/$None _) (&/$Some atype)] + (check* class-loader fixpoints invariant?? expected atype) + + [(&/$Some etype) (&/$Some atype)] + (check* class-loader fixpoints invariant?? etype atype)))) + + [(&/$VarT ?id) _] + (fn [state] + (|case ((set-var ?id actual) state) + (&/$Right state* _) + (return* state* fixpoints) + + (&/$Left _) + ((|do [bound (deref ?id)] + (check* class-loader fixpoints invariant?? bound actual)) + state))) + + [_ (&/$VarT ?id)] + (fn [state] + (|case ((set-var ?id expected) state) + (&/$Right state* _) + (return* state* fixpoints) + + (&/$Left _) + ((|do [bound (deref ?id)] + (check* class-loader fixpoints invariant?? expected bound)) + state))) + + [(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)] + (if (= eid aid) + (check* class-loader fixpoints invariant?? eA aA) + (check-error "" expected actual)) + + [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] + (fn [state] + (|case ((|do [F1 (deref ?id)] + (check* class-loader fixpoints invariant?? (&/$AppT F1 A1) actual)) + state) + (&/$Right state* output) + (return* state* output) + + (&/$Left _) + (|case F2 + (&/$UnivQ (&/$Cons _) _) + ((|do [actual* (apply-type F2 A2)] + (check* class-loader fixpoints invariant?? expected actual*)) + state) + + (&/$ExT _) + ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2)] + (check* class-loader fixpoints* invariant?? A1 A2)) + state) + + _ + ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2) + e* (apply-type F2 A1) + a* (apply-type F2 A2)] + (check* class-loader fixpoints* invariant?? e* a*)) + state)))) + + [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] + (fn [state] + (|case ((|do [F2 (deref ?id)] + (check* class-loader fixpoints invariant?? expected (&/$AppT F2 A2))) + state) + (&/$Right state* output) + (return* state* output) + + (&/$Left _) + ((|do [fixpoints* (check* class-loader fixpoints invariant?? F1 (&/$VarT ?id)) + e* (apply-type F1 A1) + a* (apply-type F1 A2)] + (check* class-loader fixpoints* invariant?? e* a*)) + state))) + + [(&/$AppT F A) _] + (let [fp-pair (&/T [expected actual]) + _ (when (> (&/|length fixpoints) 40) + (println 'FIXPOINTS (->> (&/|keys fixpoints) + (&/|map (fn [pair] + (|let [[e a] pair] + (str (show-type e) ":+:" + (show-type a))))) + (&/|interpose "\n\n") + (&/fold str ""))) + (assert false (prn-str 'check* '[(&/$AppT F A) _] (&/|length fixpoints) (show-type expected) (show-type actual))))] + (|case (fp-get fp-pair fixpoints) + (&/$Some ?) + (if ? + (return fixpoints) + (check-error "" expected actual)) + + (&/$None) + (|do [expected* (apply-type F A)] + (check* class-loader (fp-put fp-pair true fixpoints) invariant?? expected* actual)))) + + [_ (&/$AppT (&/$ExT aid) A)] + (check-error "" expected actual) + + [_ (&/$AppT F A)] + (|do [actual* (apply-type F A)] + (check* class-loader fixpoints invariant?? expected actual*)) + + [(&/$UnivQ _) _] + (|do [$arg existential + expected* (apply-type expected $arg)] + (check* class-loader fixpoints invariant?? expected* actual)) + + [_ (&/$UnivQ _)] + (with-var + (fn [$arg] + (|do [actual* (apply-type actual $arg) + =output (check* class-loader fixpoints invariant?? expected actual*) + _ (clean $arg expected)] + (return =output)))) + + [(&/$ExQ e!env e!def) _] + (with-var + (fn [$arg] + (|do [expected* (apply-type expected $arg) + =output (check* class-loader fixpoints invariant?? expected* actual) + _ (clean $arg actual)] + (return =output)))) + + [_ (&/$ExQ a!env a!def)] + (|do [$arg existential + actual* (apply-type actual $arg)] + (check* class-loader fixpoints invariant?? expected actual*)) + + [(&/$HostT e!data) (&/$HostT a!data)] + (&&host/check-host-types (partial check* class-loader fixpoints true) + check-error + fixpoints + existential + class-loader + invariant?? + e!data + a!data) + + [(&/$VoidT) (&/$VoidT)] + (return fixpoints) + + [(&/$UnitT) (&/$UnitT)] + (return fixpoints) + + [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] + (|do [fixpoints* (check* class-loader fixpoints invariant?? aI eI)] + (check* class-loader fixpoints* invariant?? eO aO)) + + [(&/$ProdT eL eR) (&/$ProdT aL aR)] + (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)] + (check* class-loader fixpoints* invariant?? eR aR)) + + [(&/$SumT eL eR) (&/$SumT aL aR)] + (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)] + (check* class-loader fixpoints* invariant?? eR aR)) + + [(&/$ExT e!id) (&/$ExT a!id)] + (if (.equals ^Object e!id a!id) + (return fixpoints) + (check-error "" expected actual)) + + [(&/$NamedT _ ?etype) _] + (check* class-loader fixpoints invariant?? ?etype actual) + + [_ (&/$NamedT _ ?atype)] + (check* class-loader fixpoints invariant?? expected ?atype) + + [_ _] + (fail "")) + (fn [err] + (check-error err expected actual))))) + +(defn check [expected actual] + (|do [class-loader &/loader + _ (check* class-loader init-fixpoints false expected actual)] + (return nil))) + +(defn actual-type [type] + "(-> Type (Lux Type))" + (|case type + (&/$AppT ?all ?param) + (|do [type* (apply-type ?all ?param)] + (actual-type type*)) + + (&/$VarT id) + (|do [=type (deref id)] + (actual-type =type)) + + (&/$NamedT ?name ?type) + (actual-type ?type) + + _ + (return type) + )) + +(defn type-name [type] + "(-> Type (Lux Ident))" + (|case type + (&/$NamedT name _) + (return name) + + _ + (fail (str "[Type Error] Type is not named: " (show-type type))) + )) + +(defn unknown? [type] + "(-> Type (Lux Bool))" + (|case type + (&/$VarT id) + (|do [? (bound? id)] + (return (not ?))) + + _ + (return false))) + +(defn resolve-type [type] + "(-> Type (Lux Type))" + (|case type + (&/$VarT id) + (|do [? (bound? id)] + (if ? + (deref id) + (return type))) + + _ + (return type))) + +(defn tuple-types-for [size-members type] + "(-> Int Type [Int (List Type)])" + (|let [?member-types (flatten-prod type) + size-types (&/|length ?member-types)] + (if (>= size-types size-members) + (&/T [size-members (&/|++ (&/|take (dec size-members) ?member-types) + (&/|list (|case (->> ?member-types (&/|drop (dec size-members)) (&/|reverse)) + (&/$Cons last prevs) + (&/fold (fn [right left] (&/$ProdT left right)) + last prevs))))]) + (&/T [size-types ?member-types]) + ))) + +(do-template [ ] + (defn [types] + (|case (&/|reverse types) + (&/$Nil) + + + (&/$Cons type (&/$Nil)) + type + + (&/$Cons last prevs) + (&/fold (fn [r l] ( l r)) last prevs))) + + fold-prod &/$UnitT &/$ProdT + fold-sum &/$VoidT &/$SumT + ) + +(def create-var+ + (|do [id create-var] + (return (&/$VarT id)))) + +(defn ^:private push-app [inf-type inf-var] + (|case inf-type + (&/$AppT inf-type* inf-var*) + (&/$AppT (push-app inf-type* inf-var) inf-var*) + + _ + (&/$AppT inf-type inf-var))) + +(defn ^:private push-name [name inf-type] + (|case inf-type + (&/$AppT inf-type* inf-var*) + (&/$AppT (push-name name inf-type*) inf-var*) + + _ + (&/$NamedT name inf-type))) + +(defn ^:private push-univq [env inf-type] + (|case inf-type + (&/$AppT inf-type* inf-var*) + (&/$AppT (push-univq env inf-type*) inf-var*) + + _ + (&/$UnivQ env inf-type))) + +(defn instantiate-inference [type] + (|case type + (&/$NamedT ?name ?type) + (|do [output (instantiate-inference ?type)] + (return (push-name ?name output))) + + (&/$UnivQ _aenv _abody) + (|do [inf-var create-var + output (instantiate-inference _abody)] + (return (push-univq _aenv (push-app output (&/$VarT inf-var))))) + + _ + (return type))) diff --git a/luxc/src/lux/type/host.clj b/luxc/src/lux/type/host.clj new file mode 100644 index 000000000..462e1aebe --- /dev/null +++ b/luxc/src/lux/type/host.clj @@ -0,0 +1,352 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.type.host + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]]) + [lux.host.generics :as &host-generics]) + (:import (java.lang.reflect GenericArrayType + ParameterizedType + TypeVariable + WildcardType))) + +;; [Exports] +(def array-data-tag "#Array") +(def null-data-tag "#Null") +(def nat-data-tag "#Nat") +(def frac-data-tag "#Frac") + +;; [Utils] +(defn ^:private trace-lineage* [^Class super-class ^Class sub-class] + "(-> Class Class (List Class))" + ;; Either they're both interfaces, of they're both classes + (let [valid-sub? #(if (or (= super-class %) + (.isAssignableFrom super-class %)) + % + nil)] + (cond (.isInterface sub-class) + (loop [sub-class sub-class + stack (&/|list)] + (let [super-interface (some valid-sub? (.getInterfaces sub-class))] + (if (= super-class super-interface) + (&/$Cons super-interface stack) + (recur super-interface (&/$Cons super-interface stack))))) + + (.isInterface super-class) + (loop [sub-class sub-class + stack (&/|list)] + (if-let [super-interface (some valid-sub? (.getInterfaces sub-class))] + (if (= super-class super-interface) + (&/$Cons super-interface stack) + (recur super-interface (&/$Cons super-interface stack))) + (let [super* (.getSuperclass sub-class)] + (recur super* (&/$Cons super* stack))))) + + :else + (loop [sub-class sub-class + stack (&/|list)] + (let [super* (.getSuperclass sub-class)] + (if (= super* super-class) + (&/$Cons super* stack) + (recur super* (&/$Cons super* stack)))))))) + +(defn ^:private trace-lineage [^Class sub-class ^Class super-class] + "(-> Class Class (List Class))" + (if (= sub-class super-class) + (&/|list) + (&/|reverse (trace-lineage* super-class sub-class)))) + +(let [matcher (fn [m ^TypeVariable jt lt] (&/$Cons (&/T [(.getName jt) lt]) m))] + (defn ^:private match-params [sub-type-params params] + (assert (and (= (&/|length sub-type-params) (&/|length params)) + (&/|every? (partial instance? TypeVariable) sub-type-params))) + (&/fold2 matcher (&/|table) sub-type-params params))) + +;; [Exports] +(let [class-name-re #"((\[+)L([^\s]+);|([^\s]+)|(\[+)([ZBSIJFDC]))" + jprim->lprim (fn [prim] + (case prim + "Z" "boolean" + "B" "byte" + "S" "short" + "I" "int" + "J" "long" + "F" "float" + "D" "double" + "C" "char"))] + (defn class->type [^Class class] + "(-> Class Type)" + (let [gclass-name (.getName class)] + (case gclass-name + ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") + (&/$HostT gclass-name (&/|list)) + ;; else + (if-let [[_ _ arr-obrackets arr-obase simple-base arr-pbrackets arr-pbase] (re-find class-name-re gclass-name)] + (let [base (or arr-obase simple-base (jprim->lprim arr-pbase))] + (if (.equals "void" base) + &/$UnitT + (reduce (fn [inner _] (&/$HostT array-data-tag (&/|list inner))) + (&/$HostT base (try (-> (Class/forName base) .getTypeParameters + seq count (repeat (&/$HostT "java.lang.Object" &/$Nil)) + &/->list) + (catch Exception e + (&/|list)))) + (range (count (or arr-obrackets arr-pbrackets ""))))) + )))))) + +(defn instance-param [existential matchings refl-type] + "(-> (Lux Type) (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" + (cond (instance? Class refl-type) + (return (class->type refl-type)) + + (instance? GenericArrayType refl-type) + (|do [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] + (return (&/$HostT array-data-tag (&/|list inner-type)))) + + (instance? ParameterizedType refl-type) + (|do [:let [refl-type* ^ParameterizedType refl-type] + params* (->> refl-type* + .getActualTypeArguments + seq &/->list + (&/map% (partial instance-param existential matchings)))] + (return (&/$HostT (->> refl-type* ^Class (.getRawType) .getName) + params*))) + + (instance? TypeVariable refl-type) + (let [gvar (.getName ^TypeVariable refl-type)] + (if-let [m-type (&/|get gvar matchings)] + (return m-type) + (fail (str "[Type Error] Unknown generic type variable: " gvar " -- " (->> matchings + (&/|map &/|first) + &/->seq))))) + + (instance? WildcardType refl-type) + (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] + (instance-param existential matchings bound) + existential))) + +(defn principal-class [refl-type] + (cond (instance? Class refl-type) + (|case (class->type refl-type) + (&/$HostT "#Array" (&/$Cons (&/$HostT class-name _) (&/$Nil))) + (str "[" (&host-generics/->type-signature class-name)) + + (&/$HostT class-name _) + (&host-generics/->type-signature class-name) + + (&/$UnitT) + "V") + + (instance? GenericArrayType refl-type) + (&host-generics/->type-signature (str refl-type)) + + (instance? ParameterizedType refl-type) + (&host-generics/->type-signature (->> ^ParameterizedType refl-type ^Class (.getRawType) .getName)) + + (instance? TypeVariable refl-type) + (if-let [bound (->> ^TypeVariable refl-type .getBounds seq first)] + (principal-class bound) + (&host-generics/->type-signature "java.lang.Object")) + + (instance? WildcardType refl-type) + (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] + (principal-class bound) + (&host-generics/->type-signature "java.lang.Object")))) + +(defn instance-gtype [existential matchings gtype] + "(-> (Lux Type) (List (, Text Type)) GenericType (Lux Type))" + (|case gtype + (&/$GenericArray component-type) + (|do [inner-type (instance-gtype existential matchings component-type)] + (return (&/$HostT array-data-tag (&/|list inner-type)))) + + (&/$GenericClass type-name type-params) + ;; When referring to type-parameters during class or method + ;; definition, a type-environment is set for storing the names + ;; of such parameters. + ;; When a "class" shows up with the name of one of those + ;; parameters, it must be detected, and the bytecode class-name + ;; must correspond to Object's. + + (if-let [m-type (&/|get type-name matchings)] + (return m-type) + (|do [params* (&/map% (partial instance-gtype existential matchings) + type-params)] + (return (&/$HostT type-name params*)))) + + (&/$GenericTypeVar var-name) + (if-let [m-type (&/|get var-name matchings)] + (return m-type) + (fail (str "[Type Error] Unknown generic type variable: " var-name " -- " (->> matchings + (&/|map &/|first) + &/->seq)))) + + (&/$GenericWildcard) + existential)) + +;; [Utils] +(defn ^:private translate-params [existential super-type-params sub-type-params params] + "(-> (List (^ java.lang.reflect.Type)) (List (^ java.lang.reflect.Type)) (List Type) (Lux (List Type)))" + (|let [matchings (match-params sub-type-params params)] + (&/map% (partial instance-param existential matchings) super-type-params))) + +(defn ^:private raise* [existential sub+params ^Class super] + "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))" + (|let [[^Class sub params] sub+params] + (if (.isInterface super) + (|do [:let [super-params (->> sub + .getGenericInterfaces + (some #(if (= super (if (instance? Class %) % (.getRawType ^ParameterizedType %))) + (if (instance? Class %) + (&/|list) + (->> ^ParameterizedType % .getActualTypeArguments seq &/->list)) + nil)))] + params* (translate-params existential + (or super-params (&/|list)) + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T [super params*]))) + (let [super* (.getGenericSuperclass sub)] + (cond (instance? Class super*) + (return (&/T [super* (&/|list)])) + + (instance? ParameterizedType super*) + (|do [params* (translate-params existential + (->> ^ParameterizedType super* .getActualTypeArguments seq &/->list) + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T [super params*]))) + + :else + (assert false (prn-str super* (class super*) [sub super]))))))) + +(defn ^:private raise [existential lineage class params] + "(-> (List Class) Class (List Type) (Lux (, Class (List Type))))" + (&/fold% (partial raise* existential) (&/T [class params]) lineage)) + +;; [Exports] +(defn ->super-type [existential class-loader super-class sub-class sub-params] + "(-> Text Text (List Type) (Lux Type))" + (let [super-class+ (Class/forName super-class true class-loader) + sub-class+ (Class/forName sub-class true class-loader)] + (if (.isAssignableFrom super-class+ sub-class+) + (let [lineage (trace-lineage sub-class+ super-class+)] + (|do [[^Class sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] + (return (&/$HostT (.getName sub-class*) sub-params*)))) + (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class " super-type existential class-loader e!name a!name a!params)] + (check (&/$HostT e!name e!params) actual*)) + + :else + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) + (catch Exception e + (prn 'check-host-types e [e!name a!name]) + (throw e))))) + +(defn gtype->gclass [gtype] + "(-> GenericType GenericClass)" + (cond (instance? Class gtype) + (&/$GenericClass (.getName ^Class gtype) &/$Nil) + + (instance? GenericArrayType gtype) + (&/$GenericArray (gtype->gclass (.getGenericComponentType ^GenericArrayType gtype))) + + (instance? ParameterizedType gtype) + (let [type-name (->> ^ParameterizedType gtype ^Class (.getRawType) .getName) + type-params (->> ^ParameterizedType gtype + .getActualTypeArguments + seq &/->list + (&/|map gtype->gclass))] + (&/$GenericClass type-name type-params)) + + (instance? TypeVariable gtype) + (&/$GenericTypeVar (.getName ^TypeVariable gtype)) + + (instance? WildcardType gtype) + (if-let [bound (->> ^WildcardType gtype .getUpperBounds seq first)] + (&/$GenericWildcard (&/$Some (&/T &/$UpperBound (gtype->gclass bound)))) + (if-let [bound (->> ^WildcardType gtype .getLowerBounds seq first)] + (&/$GenericWildcard (&/$Some (&/T &/$LowerBound (gtype->gclass bound)))) + (&/$GenericWildcard &/$None))))) + +(let [generic-type-sig "Ljava/lang/Object;"] + (defn gclass->sig [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericClass gclass-name (&/$Nil)) + (case gclass-name + "void" "V" + "boolean" "Z" + "byte" "B" + "short" "S" + "int" "I" + "long" "J" + "float" "F" + "double" "D" + "char" "C" + ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") gclass-name + ;; else + (str "L" (clojure.string/replace gclass-name #"\." "/") ";")) + + (&/$GenericArray inner-gtype) + (str "[" (gclass->sig inner-gtype)) + + (&/$GenericTypeVar ?vname) + generic-type-sig + + (&/$GenericWildcard _) + generic-type-sig + ))) diff --git a/luxc/test/test/lux/lexer.clj b/luxc/test/test/lux/lexer.clj new file mode 100644 index 000000000..3bd45cb5f --- /dev/null +++ b/luxc/test/test/lux/lexer.clj @@ -0,0 +1,276 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns test.lux.lexer + (:use clojure.test) + (:require (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [reader :as &reader] + [lexer :as &lexer]) + [lux.analyser.module :as &a-module] + :reload-all + )) + +;; [Utils] +(def ^:private module-name "test") + +(defn ^:private make-state [source-code] + (&/set$ &/$source (&reader/from module-name source-code) + (&/init-state nil))) + +;; [Tests] +(deftest lex-white-space + (let [input " \t"] + (|case (&/run-state &lexer/lex (make-state input)) + (&/$Right state [cursor (&lexer/$White_Space output)]) + (is (= input output)) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-comment + ;; Should be capable of recognizing both single-line & multi-line comments. + (let [input1 " YOLO" + input2 "\nLOL\n" + input3 " NYAN\n#(\nCAT )#\n"] + (|case (&/run-state (|do [[_ single-line] &lexer/lex + [_ multi-line] &lexer/lex + [_ multi-line-embedded] &lexer/lex] + (return (&/T [single-line multi-line multi-line-embedded]))) + (make-state (str "##" input1 "\n" "#(" input2 ")#" "\n" "#(" input3 ")#"))) + (&/$Right state [(&lexer/$Comment output1) + (&lexer/$Comment output2) + (&lexer/$Comment output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + input3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-bool + (let [input1 "true" + input2 "false"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex] + (return (&/T [output1 output2]))) + (make-state (str input1 "\n" input2))) + (&/$Right state [(&lexer/$Bool output1) + (&lexer/$Bool output2)]) + (are [input output] (= input output) + input1 output1 + input2 output2) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-int + (let [input1 "0" + input2 "12" + input3 "-123"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex] + (return (&/T [output1 output2 output3]))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state [(&lexer/$Int output1) + (&lexer/$Int output2) + (&lexer/$Int output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + input3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-real + (let [input1 "0.00123" + input2 "12.01020300" + input3 "-12.3"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex] + (return (&/T [output1 output2 output3]))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state [(&lexer/$Real output1) + (&lexer/$Real output2) + (&lexer/$Real output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + input3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-char + (let [input1 "a" + input2 "\\n" + input3 " " + input4 "\\t" + input5 "\\b" + input6 "\\r" + input7 "\\f" + input8 "\\\"" + input9 "\\\\"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex + [_ output6] &lexer/lex + [_ output7] &lexer/lex + [_ output8] &lexer/lex + [_ output9] &lexer/lex] + (return (&/T [output1 output2 output3 output4 output5 output6 output7 output8 output9]))) + (make-state (str "#\"" input1 "\"" "\n" "#\"" input2 "\"" "\n" "#\"" input3 "\"" + "\n" "#\"" input4 "\"" "\n" "#\"" input5 "\"" "\n" "#\"" input6 "\"" + "\n" "#\"" input7 "\"" "\n" "#\"" input8 "\"" "\n" "#\"" input9 "\""))) + (&/$Right state [(&lexer/$Char output1) + (&lexer/$Char output2) + (&lexer/$Char output3) + (&lexer/$Char output4) + (&lexer/$Char output5) + (&lexer/$Char output6) + (&lexer/$Char output7) + (&lexer/$Char output8) + (&lexer/$Char output9)]) + (are [input output] (= input output) + input1 output1 + "\n" output2 + input3 output3 + "\t" output4 + "\b" output5 + "\r" output6 + "\f" output7 + "\"" output8 + "\\" output9) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-text + (let [input1 "" + input2 "abc" + input3 "yolo\\nlol\\tmeme" + input4 "This is a test\\nof multi-line text.\\n\\nI just wanna make sure it works alright..."] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex] + (return (&/T [output1 output2 output3 output4]))) + (make-state (str "\"" input1 "\"" "\n" "\"" input2 "\"" "\n" "\"" input3 "\"" "\n" "\"" input4 "\""))) + (&/$Right state [(&lexer/$Text output1) + (&lexer/$Text output2) + (&lexer/$Text output3) + (&lexer/$Text output4)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + "yolo\nlol\tmeme" output3 + "This is a test\nof multi-line text.\n\nI just wanna make sure it works alright..." output4) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-symbol + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + [_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex] + (return (&/T [output1 output2 output3 output4 output5]))) + (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5 " "))) + (&/$Right state [(&lexer/$Symbol output1) + (&lexer/$Symbol output2) + (&lexer/$Symbol output3) + (&lexer/$Symbol output4) + (&lexer/$Symbol output5)]) + (are [input output] (&/ident= input output) + (&/T ["" "foo"]) output1 + (&/T ["test" "bar0123456789"]) output2 + (&/T ["lux" "b1a2z3"]) output3 + (&/T ["test" "quux"]) output4 + (&/T ["" "!_@$%^&*-+=.<>?/|\\~`':"]) output5) + + _ + (is false "Couldn't read") + ))) + +(deftest lex-tag + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + [_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex] + (return (&/T [output1 output2 output3 output4 output5]))) + (make-state (str "#" input1 "\n" "#" input2 "\n" "#" input3 "\n" "#" input4 "\n" "#" input5 " "))) + (&/$Right state [(&lexer/$Tag output1) + (&lexer/$Tag output2) + (&lexer/$Tag output3) + (&lexer/$Tag output4) + (&lexer/$Tag output5)]) + (are [input output] (&/ident= input output) + (&/T ["" "foo"]) output1 + (&/T ["test" "bar0123456789"]) output2 + (&/T ["lux" "b1a2z3"]) output3 + (&/T ["test" "quux"]) output4 + (&/T ["" "!_@$%^&*-+=.<>?/|\\~`':"]) output5) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-delimiter + (let [input1 "(" + input2 ")" + input3 "[" + input4 "]" + input5 "{" + input6 "}"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + [_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex + [_ output6] &lexer/lex] + (return (&/T [output1 output2 output3 output4 output5 output6]))) + (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5 "\n" input6))) + (&/$Right state [(&lexer/$Open_Paren) + (&lexer/$Close_Paren) + (&lexer/$Open_Bracket) + (&lexer/$Close_Bracket) + (&lexer/$Open_Brace) + (&lexer/$Close_Brace)]) + (is true) + + _ + (is false "Couldn't read.") + ))) + +(comment + (run-all-tests) + ) diff --git a/luxc/test/test/lux/parser.clj b/luxc/test/test/lux/parser.clj new file mode 100644 index 000000000..29e916b74 --- /dev/null +++ b/luxc/test/test/lux/parser.clj @@ -0,0 +1,274 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns test.lux.parser + (:use (clojure test + template)) + (:require (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [reader :as &reader] + [parser :as &parser]) + [lux.analyser.module :as &a-module] + :reload-all)) + +;; [Utils] +(def ^:private module-name "test") + +(defn ^:private make-state [source-code] + (&/set$ &/$source (&reader/from module-name source-code) + (&/init-state nil))) + +;; [Tests] +(deftest parse-white-space + (let [input " \t"] + (|case (&/run-state &parser/parse (make-state input)) + (&/$Right state (&/$Nil)) + (is true) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-comment + (let [input1 " YOLO" + input2 "\nLOL\n" + input3 " NYAN\n#(\nCAT )#\n"] + (|case (&/run-state &parser/parse (make-state (str "##" input1 "\n" "#(" input2 ")#" "\n" "#(" input3 ")#"))) + (&/$Right state (&/$Nil)) + (is true) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-bool + (let [input1 "true" + input2 "false"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse] + (return (&/|++ output1 output2))) + (make-state (str input1 "\n" input2))) + (&/$Right state (&/$Cons [_ (&/$BoolS output1)] (&/$Cons [_ (&/$BoolS output2)] (&/$Nil)))) + (are [input output] (= input output) + true output1 + false output2) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-int + (let [input1 "0" + input2 "12" + input3 "-123"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse] + (return (&/|++ output1 (&/|++ output2 output3)))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state (&/$Cons [_ (&/$IntS output1)] (&/$Cons [_ (&/$IntS output2)] (&/$Cons [_ (&/$IntS output3)] (&/$Nil))))) + (are [input output] (= input output) + 0 output1 + 12 output2 + -123 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-real + (let [input1 "0.00123" + input2 "12.01020300" + input3 "-12.3"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse] + (return (&/|++ output1 (&/|++ output2 output3)))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state (&/$Cons [_ (&/$RealS output1)] (&/$Cons [_ (&/$RealS output2)] (&/$Cons [_ (&/$RealS output3)] (&/$Nil))))) + (are [input output] (= input output) + 0.00123 output1 + 12.010203 output2 + -12.3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-char + (let [input1 "a" + input2 "\\n" + input3 " " + input4 "\\t" + input5 "\\b" + input6 "\\r" + input7 "\\f" + input8 "\\\"" + input9 "\\\\"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse + output5 &parser/parse + output6 &parser/parse + output7 &parser/parse + output8 &parser/parse + output9 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 (&/|++ output5 (&/|++ output6 (&/|++ output7 (&/|++ output8 output9)))))))))) + (make-state (str "#\"" input1 "\"" "\n" "#\"" input2 "\"" "\n" "#\"" input3 "\"" + "\n" "#\"" input4 "\"" "\n" "#\"" input5 "\"" "\n" "#\"" input6 "\"" + "\n" "#\"" input7 "\"" "\n" "#\"" input8 "\"" "\n" "#\"" input9 "\""))) + (&/$Right state (&/$Cons [_ (&/$CharS output1)] + (&/$Cons [_ (&/$CharS output2)] + (&/$Cons [_ (&/$CharS output3)] + (&/$Cons [_ (&/$CharS output4)] + (&/$Cons [_ (&/$CharS output5)] + (&/$Cons [_ (&/$CharS output6)] + (&/$Cons [_ (&/$CharS output7)] + (&/$Cons [_ (&/$CharS output8)] + (&/$Cons [_ (&/$CharS output9)] + (&/$Nil))))))))))) + (are [input output] (= input output) + \a output1 + \newline output2 + \space output3 + \tab output4 + \backspace output5 + \return output6 + \formfeed output7 + \" output8 + \\ output9) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-text + (let [input1 "" + input2 "abc" + input3 "yolo\\nlol\\tmeme" + input4 "This is a test\\nof multi-line text.\\n\\nI just wanna make sure it works alright..."] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 output4))))) + (make-state (str "\"" input1 "\"" "\n" "\"" input2 "\"" "\n" "\"" input3 "\"" "\n" "\"" input4 "\""))) + (&/$Right state (&/$Cons [_ (&/$TextS output1)] (&/$Cons [_ (&/$TextS output2)] (&/$Cons [_ (&/$TextS output3)] (&/$Cons [_ (&/$TextS output4)] (&/$Nil)))))) + (are [input output] (= input output) + input1 output1 + input2 output2 + "yolo\nlol\tmeme" output3 + "This is a test\nof multi-line text.\n\nI just wanna make sure it works alright..." output4) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-symbol + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse + output5 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 output5)))))) + (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5 " "))) + (&/$Right state (&/$Cons [_ (&/$SymbolS output1)] + (&/$Cons [_ (&/$SymbolS output2)] + (&/$Cons [_ (&/$SymbolS output3)] + (&/$Cons [_ (&/$SymbolS output4)] + (&/$Cons [_ (&/$SymbolS output5)] + (&/$Nil))))))) + (are [input output] (&/ident= input output) + (&/T ["" "foo"]) output1 + (&/T ["test" "bar0123456789"]) output2 + (&/T ["lux" "b1a2z3"]) output3 + (&/T ["test" "quux"]) output4 + (&/T ["" "!_@$%^&*-+=.<>?/|\\~`':"]) output5) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-tag + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse + output5 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 output5)))))) + (make-state (str "#" input1 "\n" "#" input2 "\n" "#" input3 "\n" "#" input4 "\n" "#" input5 " "))) + (&/$Right state (&/$Cons [_ (&/$TagS output1)] + (&/$Cons [_ (&/$TagS output2)] + (&/$Cons [_ (&/$TagS output3)] + (&/$Cons [_ (&/$TagS output4)] + (&/$Cons [_ (&/$TagS output5)] + (&/$Nil))))))) + (are [input output] (&/ident= input output) + (&/T ["" "foo"]) output1 + (&/T ["test" "bar0123456789"]) output2 + (&/T ["lux" "b1a2z3"]) output3 + (&/T ["test" "quux"]) output4 + (&/T ["" "!_@$%^&*-+=.<>?/|\\~`':"]) output5) + + _ + (is false "Couldn't read.") + ))) + +(do-template [ ] + (deftest + (let [input1 "yolo 123 \"lol\" #meme"] + (|case (&/run-state &parser/parse + (make-state (str input1 ))) + (&/$Right state (&/$Cons [_ ( (&/$Cons [_ (&/$SymbolS symv)] + (&/$Cons [_ (&/$IntS intv)] + (&/$Cons [_ (&/$TextS textv)] + (&/$Cons [_ (&/$TagS tagv)] + (&/$Nil))))))] + (&/$Nil))) + (do (is (&/ident= (&/T ["" "yolo"]) symv)) + (is (= 123 intv)) + (is (= "lol" textv)) + (is (&/ident= (&/T ["" "meme"]) tagv))) + + _ + (is false "Couldn't read.") + ))) + + parse-form &/$FormS "(" ")" + parse-tuple &/$TupleS "[" "]" + ) + +(deftest parse-record + (let [input1 "yolo 123 \"lol\" #meme"] + (|case (&/run-state &parser/parse + (make-state (str "{" input1 "}"))) + (&/$Right state (&/$Cons [_ (&/$RecordS (&/$Cons [[_ (&/$SymbolS symv)] [_ (&/$IntS intv)]] + (&/$Cons [[_ (&/$TextS textv)] [_ (&/$TagS tagv)]] + (&/$Nil))))] + (&/$Nil))) + (do (is (&/ident= (&/T ["" "yolo"]) symv)) + (is (= 123 intv)) + (is (= "lol" textv)) + (is (&/ident= (&/T ["" "meme"]) tagv))) + + _ + (is false "Couldn't read.") + ))) + +(comment + (run-all-tests) + ) diff --git a/luxc/test/test/lux/reader.clj b/luxc/test/test/lux/reader.clj new file mode 100644 index 000000000..ee9cb4c35 --- /dev/null +++ b/luxc/test/test/lux/reader.clj @@ -0,0 +1,53 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns test.lux.reader + (:use clojure.test) + (:require (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [reader :as &reader]) + :reload-all)) + +;; [Utils] +(def source (&reader/from "test" "lol\nmeme\nnyan cat\n\nlolcat")) +(def init-state (&/set$ &/$source source (&/init-state nil))) + +;; [Tests] +(deftest test-source-code-reading + (is (= 5 (&/|length source)))) + +(deftest test-text-reading + ;; Should be capable of recognizing literal texts. + (let [input "lo"] + (|case (&/run-state (&reader/read-text input) init-state) + (&/$Right state [cursor end-line? output]) + (is (= input output)) + + _ + (is false "Couldn't read.") + ))) + +(deftest test-regex-reading + ;; Should be capable of matching simple, grouping regex-patterns. + (|case (&/run-state (&reader/read-regex #"l(.)l") init-state) + (&/$Right state [cursor end-line? output]) + (is (= "lol" output)) + + _ + (is false "Couldn't read.") + )) + +(deftest test-regex+-reading + ;; Should be capable of matching multi-line regex-patterns. + (|case (&/run-state (&reader/read-regex+ #"(?is)^((?!cat).)*") init-state) + (&/$Right state [cursor output]) + (is (= "\nlol\nmeme\nnyan " output)) + + _ + (is false "Couldn't read.") + )) + +(comment + (run-all-tests) + ) diff --git a/luxc/test/test/lux/type.clj b/luxc/test/test/lux/type.clj new file mode 100644 index 000000000..1a43f7cc4 --- /dev/null +++ b/luxc/test/test/lux/type.clj @@ -0,0 +1,473 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns test.lux.type + (:use clojure.test) + (:require (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [type :as &type]) + :reload-all + )) + +;; [Tests] +(deftest check-base-types + (|case (&/run-state (|do [_ (&type/check &/$UnitT &/$UnitT) + + _ (&type/check &/$VoidT &/$VoidT)] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-simple-host-types + (|case (&/run-state (|do [_ (&type/check (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + + _ (&type/check (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-complex-host-types + (|case (&/run-state (|do [_ (&type/check (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Object" &/$Nil))) + (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$HostT "java.util.ArrayList" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil))))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-named-types + (|case (&/run-state (|do [_ (&type/check (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$HostT "java.lang.Boolean" &/$Nil)) + + _ (&type/check (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil)))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-sum-types + (|case (&/run-state (|do [_ (&type/check (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$SumT (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$SumT (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Object" &/$Nil)) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$SumT (&/$HostT "java.lang.Object" &/$Nil) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$SumT (&/$HostT "java.lang.Object" &/$Nil) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Object" &/$Nil))) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-prod-types + (|case (&/run-state (|do [_ (&type/check (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$ProdT (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$ProdT (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Object" &/$Nil)) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$ProdT (&/$HostT "java.lang.Object" &/$Nil) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$ProdT (&/$HostT "java.lang.Object" &/$Nil) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Object" &/$Nil))) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-lambda-types + (|case (&/run-state (|do [_ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$LambdaT (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Object" &/$Nil)) + (&/$LambdaT (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$LambdaT (&/$HostT "java.lang.Object" &/$Nil) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Object" &/$Nil))) + (&/$LambdaT (&/$HostT "java.lang.Object" &/$Nil) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + ] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-ex-types + (|case (&/run-state (|do [_ (&type/check (&/$ExT 0) (&/$ExT 0))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-univ-quantification + (|case (&/run-state (|do [_ (&type/check (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1)))) + + _ (&type/check (&/$UnivQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1))) + (&/$UnivQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1)))) + + _ (&type/check (&/$UnivQ (&/|list) + (&/$SumT + ;; lux;Nil + &/$UnitT + ;; lux;Cons + (&/$ProdT (&/$BoundT 1) + (&/$AppT (&/$BoundT 0) + (&/$BoundT 1))))) + (&/$UnivQ (&/|list) + (&/$SumT + ;; lux;Nil + &/$UnitT + ;; lux;Cons + (&/$ProdT (&/$BoundT 1) + (&/$AppT (&/$BoundT 0) + (&/$BoundT 1))))))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-ex-quantification + (|case (&/run-state (|do [_ (&type/check (&/$ExQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$ExQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1)))) + + _ (&type/check (&/$ExQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1))) + (&/$ExQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1)))) + + _ (&type/check (&/$ExQ (&/|list) + (&/$SumT + ;; lux;Nil + &/$UnitT + ;; lux;Cons + (&/$ProdT (&/$BoundT 1) + (&/$AppT (&/$BoundT 0) + (&/$BoundT 1))))) + (&/$ExQ (&/|list) + (&/$SumT + ;; lux;Nil + &/$UnitT + ;; lux;Cons + (&/$ProdT (&/$BoundT 1) + (&/$AppT (&/$BoundT 0) + (&/$BoundT 1))))))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-app-type + (|case (&/run-state (|do [_ (&type/check (&/$AppT (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$AppT (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$AppT (&/$UnivQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1))) + (&/$HostT "java.lang.Object" &/$Nil)) + (&/$AppT (&/$UnivQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$AppT (&/$ExQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$AppT (&/$ExQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$AppT (&/$ExQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1))) + (&/$HostT "java.lang.Object" &/$Nil)) + (&/$AppT (&/$ExQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil)))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-var-type + (|case (&/run-state (|do [_ (&type/with-var + (fn [$var] + (|do [_ (&type/check $var (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$HostT "java.lang.Boolean" (&/$Nil)) (&type/deref+ $var)] + (return nil)))) + + _ (&type/with-var + (fn [$var] + (|do [_ (&type/check (&/$AppT (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + $var) + (&/$AppT (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$HostT "java.lang.Boolean" (&/$Nil)) (&type/deref+ $var)] + (return nil)))) + + _ (&type/with-var + (fn [$var] + (|do [_ (&type/check (&/$HostT "java.lang.Boolean" &/$Nil) $var) + (&/$HostT "java.lang.Boolean" (&/$Nil)) (&type/deref+ $var)] + (return nil)))) + + _ (&type/with-var + (fn [$var] + (|do [_ (&type/check (&/$AppT (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$AppT (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + $var)) + (&/$HostT "java.lang.Boolean" (&/$Nil)) (&type/deref+ $var)] + (return nil)))) + + _ (&type/with-var + (fn [$var1] + (&type/with-var + (fn [$var2] + (|do [_ (&type/check $var1 $var2)] + (return nil)))))) + + _ (&type/with-var + (fn [$var1] + (&type/with-var + (fn [$var2] + (|do [_ (&type/check $var2 $var1)] + (return nil)))))) + + _ (&type/with-var + (fn [$var1] + (&type/with-var + (fn [$var2] + (|do [_ (&type/check $var1 $var2) + _ (&type/check $var1 (&/$HostT "java.lang.Boolean" (&/|list))) + =var1 (&type/deref+ $var1) + _ (&/assert! (&type/type= =var1 $var2) "") + =var2 (&type/deref+ $var2) + _ (&/assert! (&type/type= =var2 (&/$HostT "java.lang.Boolean" (&/|list))) "")] + (return nil)))))) + + _ (&type/with-var + (fn [$var1] + (&type/with-var + (fn [$var2] + (|do [_ (&type/check $var2 $var1) + _ (&type/check $var1 (&/$HostT "java.lang.Boolean" (&/|list))) + =var2 (&type/deref+ $var2) + _ (&/assert! (&type/type= =var2 $var1) "") + =var1 (&type/deref+ $var1) + _ (&/assert! (&type/type= =var1 (&/$HostT "java.lang.Boolean" (&/|list))) "")] + (return nil)))))) + + _ (&type/with-var + (fn [$var1] + (&type/with-var + (fn [$var2] + (|do [_ (&type/check $var1 $var2) + _ (&type/check $var2 (&/$HostT "java.lang.Boolean" (&/|list))) + =var1 (&type/deref+ $var1) + _ (&/assert! (&type/type= =var1 $var2) "") + =var2 (&type/deref+ $var2) + _ (&/assert! (&type/type= =var2 (&/$HostT "java.lang.Boolean" (&/|list))) "")] + (return nil)))))) + + _ (&type/with-var + (fn [$var1] + (&type/with-var + (fn [$var2] + (|do [_ (&type/check $var2 $var1) + _ (&type/check $var2 (&/$HostT "java.lang.Boolean" (&/|list))) + =var2 (&type/deref+ $var2) + _ (&/assert! (&type/type= =var2 $var1) "") + =var1 (&type/deref+ $var1) + _ (&/assert! (&type/type= =var1 (&/$HostT "java.lang.Boolean" (&/|list))) "")] + (return nil))))))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(comment + (run-all-tests) + ) diff --git a/project.clj b/project.clj deleted file mode 100644 index 4650fbd58..000000000 --- a/project.clj +++ /dev/null @@ -1,30 +0,0 @@ -(defproject com.github.luxlang/luxc-jvm "0.5.0-SNAPSHOT" - :min-lein-version "2.1.0" ;; 2.1.0 introduced jar classifiers - :description "The JVM compiler for the Lux programming language." - :url "https://github.com/LuxLang/lux" - :license {:name "Mozilla Public License (Version 2.0)" - :url "https://www.mozilla.org/en-US/MPL/2.0/"} - :deploy-repositories [["releases" {:url "https://oss.sonatype.org/service/local/staging/deploy/maven2/" - :creds :gpg}] - ["snapshots" {:url "https://oss.sonatype.org/content/repositories/snapshots/" - :creds :gpg}]] - :pom-addition [:developers [:developer - [:name "Eduardo Julian"] - [:url "https://github.com/eduardoejp"]]] - :dependencies [[org.clojure/clojure "1.6.0"] - [org.clojure/core.match "0.2.1"] - [org.ow2.asm/asm-all "5.0.3"]] - :warn-on-reflection true - :main lux - :repositories [["snapshots" "https://oss.sonatype.org/content/repositories/snapshots/"] - ["releases" "https://oss.sonatype.org/service/local/staging/deploy/maven2/"]] - :source-paths ["src"] - - :classifiers {:sources {:resource-paths ["src"]} - :javadoc {:resource-paths ["src"]}} - - :aot [lux] - - :jvm-opts ^:replace ["-server" "-Xms2048m" "-Xmx2048m" - "-XX:+OptimizeStringConcat"] - ) diff --git a/src/lux.clj b/src/lux.clj deleted file mode 100644 index e6fc3f4cc..000000000 --- a/src/lux.clj +++ /dev/null @@ -1,38 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux - (:gen-class) - (:require [lux.base :as & :refer [|let |do return fail return* fail* |case]] - [lux.compiler.base :as &compiler-base] - [lux.compiler :as &compiler] - [lux.repl :as &repl] - [clojure.string :as string] - :reload-all) - (:import (java.io File))) - -(def unit-separator (str (char 31))) - -(defn ^:private process-dirs - "(-> Text (List Text))" - [resources-dirs] - (-> resources-dirs - (string/replace unit-separator "\n") - string/split-lines - &/->list)) - -(defn -main [& args] - (|case (&/->list args) - (&/$Cons "release" (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil)))))) - (time (&compiler/compile-program &/$Release program-module (process-dirs resources-dirs) (process-dirs source-dirs) target-dir)) - - (&/$Cons "debug" (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil)))))) - (time (&compiler/compile-program &/$Debug program-module (process-dirs resources-dirs) (process-dirs source-dirs) target-dir)) - - (&/$Cons "repl" (&/$Cons source-dirs (&/$Nil))) - (&repl/repl (process-dirs source-dirs)) - - _ - (println "Can't understand command."))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj deleted file mode 100644 index 4133927e7..000000000 --- a/src/lux/analyser.clj +++ /dev/null @@ -1,211 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.analyser - (:require (clojure [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return fail return* fail* |case]] - [reader :as &reader] - [parser :as &parser] - [type :as &type] - [host :as &host]) - (lux.analyser [base :as &&] - [lux :as &&lux] - [host :as &&host] - [module :as &&module] - [parser :as &&a-parser]))) - -;; [Utils] -(defn analyse-variant+ [analyse exo-type ident values] - (|do [[module tag-name] (&/normalize ident) - _ (&&module/ensure-can-see-tag module tag-name) - idx (&&module/tag-index module tag-name) - group (&&module/tag-group module tag-name) - :let [is-last? (= idx (dec (&/|length group)))]] - (if (= 1 (&/|length group)) - (|do [_cursor &/cursor] - (analyse exo-type (&/T [_cursor (&/$TupleS values)]))) - (|case exo-type - (&/$VarT id) - (|do [? (&type/bound? id)] - (if (or ? (&&/type-tag? module tag-name)) - (&&lux/analyse-variant analyse (&/$Right exo-type) idx is-last? values) - (|do [wanted-type (&&module/tag-type module tag-name) - wanted-type* (&type/instantiate-inference wanted-type) - [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyse (&/$Left wanted-type*) idx is-last? values)) - _ (&type/check exo-type variant-type)] - (return (&/|list (&&/|meta exo-type variant-cursor variant-analysis)))))) - - _ - (&&lux/analyse-variant analyse (&/$Right exo-type) idx is-last? values) - )) - )) - -(defn ^:private just-analyse [analyser syntax] - (&type/with-var - (fn [?var] - (|do [[[?output-type ?output-cursor] ?output-term] (&&/analyse-1 analyser ?var syntax)] - (|case [?var ?output-type] - [(&/$VarT ?e-id) (&/$VarT ?a-id)] - (if (= ?e-id ?a-id) - (|do [=output-type (&type/clean ?var ?output-type)] - (return (&&/|meta =output-type ?output-cursor ?output-term))) - (|do [=output-type (&type/clean ?var ?var)] - (return (&&/|meta =output-type ?output-cursor ?output-term)))) - - [_ _] - (|do [=output-type (&type/clean ?var ?output-type)] - (return (&&/|meta =output-type ?output-cursor ?output-term)))) - )))) - -(defn ^:private analyse-ast [optimize eval! compile-module compilers exo-type ?token] - (|let [analyse (partial analyse-ast optimize eval! compile-module compilers) - [cursor token] ?token - [compile-def compile-program compile-class compile-interface] compilers] - (|case token - ;; Standard special forms - (&/$BoolS ?value) - (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&&/|meta exo-type cursor (&&/$bool ?value))))) - - (&/$NatS ?value) - (|do [_ (&type/check exo-type &type/Nat)] - (return (&/|list (&&/|meta exo-type cursor (&&/$nat ?value))))) - - (&/$IntS ?value) - (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&&/|meta exo-type cursor (&&/$int ?value))))) - - (&/$RealS ?value) - (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&&/|meta exo-type cursor (&&/$real ?value))))) - - (&/$CharS ?value) - (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&&/|meta exo-type cursor (&&/$char ?value))))) - - (&/$TextS ?value) - (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&&/|meta exo-type cursor (&&/$text ?value))))) - - (&/$TupleS ?elems) - (&/with-analysis-meta cursor exo-type - (&&lux/analyse-tuple analyse (&/$Right exo-type) ?elems)) - - (&/$RecordS ?elems) - (&/with-analysis-meta cursor exo-type - (&&lux/analyse-record analyse exo-type ?elems)) - - (&/$TagS ?ident) - (&/with-analysis-meta cursor exo-type - (analyse-variant+ analyse exo-type ?ident &/$Nil)) - - (&/$SymbolS ?ident) - (&/with-analysis-meta cursor exo-type - (&&lux/analyse-symbol analyse exo-type ?ident)) - - (&/$FormS (&/$Cons [command-meta command] parameters)) - (|case command - (&/$SymbolS _ command-name) - (case command-name - "_lux_case" - (|let [(&/$Cons ?value ?branches) parameters] - (&/with-analysis-meta cursor exo-type - (&&lux/analyse-case analyse exo-type ?value ?branches))) - - "_lux_lambda" - (|let [(&/$Cons [_ (&/$SymbolS "" ?self)] - (&/$Cons [_ (&/$SymbolS "" ?arg)] - (&/$Cons ?body - (&/$Nil)))) parameters] - (&/with-analysis-meta cursor exo-type - (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body))) - - "_lux_proc" - (|let [(&/$Cons [_ (&/$TupleS (&/$Cons [_ (&/$TextS ?category)] - (&/$Cons [_ (&/$TextS ?proc)] - (&/$Nil))))] - (&/$Cons [_ (&/$TupleS ?args)] - (&/$Nil))) parameters] - (&/with-analysis-meta cursor exo-type - (&&host/analyse-host analyse exo-type compilers ?category ?proc ?args))) - - "_lux_:" - (|let [(&/$Cons ?type - (&/$Cons ?value - (&/$Nil))) parameters] - (&/with-analysis-meta cursor exo-type - (&&lux/analyse-ann analyse eval! exo-type ?type ?value))) - - "_lux_:!" - (|let [(&/$Cons ?type - (&/$Cons ?value - (&/$Nil))) parameters] - (&/with-analysis-meta cursor exo-type - (&&lux/analyse-coerce analyse eval! exo-type ?type ?value))) - - "_lux_def" - (|let [(&/$Cons [_ (&/$SymbolS "" ?name)] - (&/$Cons ?value - (&/$Cons ?meta - (&/$Nil)) - )) parameters] - (&/with-cursor cursor - (&&lux/analyse-def analyse optimize eval! compile-def ?name ?value ?meta))) - - "_lux_module" - (|let [(&/$Cons ?meta (&/$Nil)) parameters] - (&/with-cursor cursor - (&&lux/analyse-module analyse optimize eval! compile-module ?meta))) - - "_lux_program" - (|let [(&/$Cons [_ (&/$SymbolS "" ?args)] - (&/$Cons ?body - (&/$Nil))) parameters] - (&/with-cursor cursor - (&&lux/analyse-program analyse optimize compile-program ?args ?body))) - - ;; else - (&/with-cursor cursor - (|do [=fn (just-analyse analyse (&/T [command-meta command]))] - (&&lux/analyse-apply analyse cursor exo-type =fn parameters)))) - - (&/$NatS idx) - (&/with-analysis-meta cursor exo-type - (&&lux/analyse-variant analyse (&/$Right exo-type) idx nil parameters)) - - (&/$TagS ?ident) - (&/with-analysis-meta cursor exo-type - (analyse-variant+ analyse exo-type ?ident parameters)) - - _ - (&/with-cursor cursor - (|do [=fn (just-analyse analyse (&/T [command-meta command]))] - (&&lux/analyse-apply analyse cursor exo-type =fn parameters)))) - - _ - (&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T [(&/T ["" -1 -1]) token]))))) - ))) - -;; [Resources] -(defn analyse [optimize eval! compile-module compilers] - (|do [asts &parser/parse] - (&/flat-map% (partial analyse-ast optimize eval! compile-module compilers &/$VoidT) asts))) - -(defn clean-output [?var analysis] - (|do [:let [[[?output-type ?output-cursor] ?output-term] analysis] - =output-type (&type/clean ?var ?output-type)] - (return (&&/|meta =output-type ?output-cursor ?output-term)))) - -(defn repl-analyse [optimize eval! compile-module compilers] - (|do [asts &parser/parse] - (&/flat-map% (fn [ast] - (&type/with-var - (fn [?var] - (|do [=outputs (&/with-closure - (analyse-ast optimize eval! compile-module compilers ?var ast))] - (&/map% (partial clean-output ?var) =outputs))))) - asts))) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj deleted file mode 100644 index 9bdcdeb11..000000000 --- a/src/lux/analyser/base.clj +++ /dev/null @@ -1,131 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.analyser.base - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [defvariant |let |do return* return fail |case]] - [type :as &type]))) - -;; [Tags] -(defvariant - ("bool" 1) - ("nat" 1) - ("int" 1) - ("frac" 1) - ("real" 1) - ("char" 1) - ("text" 1) - ("variant" 3) - ("tuple" 1) - ("apply" 2) - ("case" 2) - ("lambda" 4) - ("ann" 2) - ("var" 1) - ("captured" 1) - ("proc" 3) - ) - -;; [Exports] -(defn expr-meta [analysis] - (|let [[meta _] analysis] - meta)) - -(defn expr-type* [analysis] - (|let [[[type _] _] analysis] - type)) - -(defn expr-term [analysis] - (|let [[[type _] term] analysis] - term)) - -(defn with-type [new-type analysis] - (|let [[[type cursor] adt] analysis] - (&/T [(&/T [new-type cursor]) adt]))) - -(defn clean-analysis [$var an] - "(-> Type Analysis (Lux Analysis))" - (|do [=an-type (&type/clean $var (expr-type* an))] - (return (with-type =an-type an)))) - -(def jvm-this "_jvm_this") - -(defn cap-1 [action] - (|do [result action] - (|case result - (&/$Cons x (&/$Nil)) - (return x) - - _ - (fail "[Analyser Error] Can't expand to other than 1 element.")))) - -(defn analyse-1 [analyse exo-type elem] - (&/with-expected-type exo-type - (cap-1 (analyse exo-type elem)))) - -(defn analyse-1+ [analyse ?token] - (&type/with-var - (fn [$var] - (|do [=expr (analyse-1 analyse $var ?token)] - (clean-analysis $var =expr))))) - -(defn resolved-ident [ident] - (|do [:let [[?module ?name] ident] - module* (if (.equals "" ?module) - &/get-module-name - (return ?module))] - (return (&/T [module* ?name])))) - -(let [tag-names #{"HostT" "VoidT" "UnitT" "SumT" "ProdT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}] - (defn type-tag? [module name] - (and (= "lux" module) - (contains? tag-names name)))) - -(defn |meta [type cursor analysis] - (&/T [(&/T [type cursor]) analysis])) - -(defn de-meta - "(-> Analysis Analysis)" - [analysis] - (|let [[meta analysis-] analysis] - (|case analysis- - ($variant idx is-last? value) - ($variant idx is-last? (de-meta value)) - - ($tuple elems) - ($tuple (&/|map de-meta elems)) - - ($apply func args) - ($apply (de-meta func) - (&/|map de-meta args)) - - ($case value branches) - ($case (de-meta value) - (&/|map (fn [branch] - (|let [[_pattern _body] branch] - (&/T [_pattern (de-meta _body)]))) - branches)) - - ($lambda _register-offset scope captured body) - ($lambda _register-offset scope - (&/|map (fn [branch] - (|let [[_name _captured] branch] - (&/T [_name (de-meta _captured)]))) - captured) - (de-meta body)) - - ($ann value-expr type-expr) - (de-meta value-expr) - - ($captured scope idx source) - ($captured scope idx (de-meta source)) - - ($proc proc-ident args special-args) - ($proc proc-ident (&/|map de-meta args) special-args) - - _ - analysis- - ))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj deleted file mode 100644 index 6841577a8..000000000 --- a/src/lux/analyser/case.clj +++ /dev/null @@ -1,654 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.analyser.case - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [defvariant |do return fail |let |case]] - [parser :as &parser] - [type :as &type]) - (lux.analyser [base :as &&] - [env :as &env] - [module :as &module] - [record :as &&record]))) - -;; [Tags] -(defvariant - ("DefaultTotal" 1) - ("BoolTotal" 2) - ("NatTotal" 2) - ("IntTotal" 2) - ("FracTotal" 2) - ("RealTotal" 2) - ("CharTotal" 2) - ("TextTotal" 2) - ("TupleTotal" 2) - ("VariantTotal" 2)) - -(defvariant - ("NoTestAC" 0) - ("StoreTestAC" 1) - ("BoolTestAC" 1) - ("NatTestAC" 1) - ("IntTestAC" 1) - ("FracTestAC" 1) - ("RealTestAC" 1) - ("CharTestAC" 1) - ("TextTestAC" 1) - ("TupleTestAC" 1) - ("VariantTestAC" 1)) - -;; [Utils] -(def ^:private unit-tuple - (&/T [(&/T ["" -1 -1]) (&/$TupleS &/$Nil)])) - -(defn ^:private resolve-type [type] - (|case type - (&/$VarT ?id) - (|do [type* (&/try-all% (&/|list (&type/deref ?id) - (fail "##1##")))] - (resolve-type type*)) - - (&/$UnivQ _) - (|do [$var &type/existential - =type (&type/apply-type type $var)] - (&type/actual-type =type)) - - (&/$ExQ _ _) - (|do [$var &type/existential - =type (&type/apply-type type $var)] - (&type/actual-type =type)) - - _ - (&type/actual-type type))) - -(defn update-up-frame [frame] - (|let [[_env _idx _var] frame] - (&/T [_env (+ 2 _idx) _var]))) - -(defn clean! [level ?tid bound-idx type] - (|case type - (&/$VarT ?id) - (if (= ?tid ?id) - (&/$BoundT (+ (* 2 level) bound-idx)) - type) - - (&/$HostT ?name ?params) - (&/$HostT ?name (&/|map (partial clean! level ?tid bound-idx) - ?params)) - - (&/$LambdaT ?arg ?return) - (&/$LambdaT (clean! level ?tid bound-idx ?arg) - (clean! level ?tid bound-idx ?return)) - - (&/$AppT ?lambda ?param) - (&/$AppT (clean! level ?tid bound-idx ?lambda) - (clean! level ?tid bound-idx ?param)) - - (&/$ProdT ?left ?right) - (&/$ProdT (clean! level ?tid bound-idx ?left) - (clean! level ?tid bound-idx ?right)) - - (&/$SumT ?left ?right) - (&/$SumT (clean! level ?tid bound-idx ?left) - (clean! level ?tid bound-idx ?right)) - - (&/$UnivQ ?env ?body) - (&/$UnivQ (&/|map (partial clean! level ?tid bound-idx) ?env) - (clean! (inc level) ?tid bound-idx ?body)) - - (&/$ExQ ?env ?body) - (&/$ExQ (&/|map (partial clean! level ?tid bound-idx) ?env) - (clean! (inc level) ?tid bound-idx ?body)) - - _ - type - )) - -(defn beta-reduce! [level env type] - (|case type - (&/$HostT ?name ?params) - (&/$HostT ?name (&/|map (partial beta-reduce! level env) ?params)) - - (&/$SumT ?left ?right) - (&/$SumT (beta-reduce! level env ?left) - (beta-reduce! level env ?right)) - - (&/$ProdT ?left ?right) - (&/$ProdT (beta-reduce! level env ?left) - (beta-reduce! level env ?right)) - - (&/$AppT ?type-fn ?type-arg) - (&/$AppT (beta-reduce! level env ?type-fn) - (beta-reduce! level env ?type-arg)) - - (&/$UnivQ ?local-env ?local-def) - (&/$UnivQ ?local-env (beta-reduce! (inc level) env ?local-def)) - - (&/$ExQ ?local-env ?local-def) - (&/$ExQ ?local-env (beta-reduce! (inc level) env ?local-def)) - - (&/$LambdaT ?input ?output) - (&/$LambdaT (beta-reduce! level env ?input) - (beta-reduce! level env ?output)) - - (&/$BoundT ?idx) - (|case (&/|at (- ?idx (* 2 level)) env) - (&/$Some bound) - (beta-reduce! level env bound) - - _ - type) - - _ - type - )) - -(defn apply-type! [type-fn param] - (|case type-fn - (&/$UnivQ local-env local-def) - (return (beta-reduce! 0 (->> local-env - (&/$Cons param) - (&/$Cons type-fn)) - local-def)) - - (&/$ExQ local-env local-def) - (return (beta-reduce! 0 (->> local-env - (&/$Cons param) - (&/$Cons type-fn)) - local-def)) - - (&/$AppT F A) - (|do [type-fn* (apply-type! F A)] - (apply-type! type-fn* param)) - - (&/$NamedT ?name ?type) - (apply-type! ?type param) - - (&/$ExT id) - (return (&/$AppT type-fn param)) - - (&/$VarT id) - (|do [=type-fun (deref id)] - (apply-type! =type-fun param)) - - _ - (fail (str "[Type System] Not a type function:\n" (&type/show-type type-fn) "\n")))) - -(defn adjust-type* [up type] - "(-> (List (, (Maybe (List Type)) Int Type)) Type (Lux Type))" - (|case type - (&/$UnivQ _aenv _abody) - (&type/with-var - (fn [$var] - (|do [=type (apply-type! type $var) - ==type (adjust-type* (&/$Cons (&/T [_aenv 1 $var]) (&/|map update-up-frame up)) =type)] - (&type/clean $var ==type)))) - - (&/$ExQ _aenv _abody) - (|do [$var &type/existential - =type (apply-type! type $var)] - (adjust-type* up =type)) - - (&/$ProdT ?left ?right) - (|do [:let [=type (&/fold (fn [_abody ena] - (|let [[_aenv _aidx (&/$VarT _avar)] ena] - (clean! 0 _avar _aidx _abody))) - type - up)] - :let [distributor (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aidx _avar] ena] - (&/$UnivQ _aenv _abody))) - v - up)) - adjusted-type (&type/Tuple$ (&/|map distributor (&type/flatten-prod =type)))]] - (return adjusted-type)) - - (&/$SumT ?left ?right) - (|do [:let [=type (&/fold (fn [_abody ena] - (|let [[_aenv _aidx (&/$VarT _avar)] ena] - (clean! 0 _avar _aidx _abody))) - type - up)] - :let [distributor (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aidx _avar] ena] - (&/$UnivQ _aenv _abody))) - v - up)) - adjusted-type (&type/Variant$ (&/|map distributor (&type/flatten-sum =type)))]] - (return adjusted-type)) - - (&/$AppT ?tfun ?targ) - (|do [=type (apply-type! ?tfun ?targ)] - (adjust-type* up =type)) - - (&/$VarT ?id) - (|do [type* (&/try-all% (&/|list (&type/deref ?id) - (fail (str "##2##: " ?id))))] - (adjust-type* up type*)) - - (&/$NamedT ?name ?type) - (adjust-type* up ?type) - - (&/$UnitT) - (return type) - - _ - (fail (str "[Pattern-matching Error] Can't adjust type: " (&type/show-type type))) - )) - -(defn adjust-type [type] - "(-> Type (Lux Type))" - (adjust-type* &/$Nil type)) - -(defn ^:private analyse-pattern [var?? value-type pattern kont] - (|let [[meta pattern*] pattern] - (|case pattern* - (&/$SymbolS "" name) - (|case var?? - (&/$Some var-analysis) - (|do [=kont (&env/with-alias name var-analysis - kont)] - (return (&/T [$NoTestAC =kont]))) - - _ - (|do [=kont (&env/with-local name value-type - kont) - idx &env/next-local-idx] - (return (&/T [($StoreTestAC idx) =kont])))) - - (&/$SymbolS ident) - (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) - - (&/$BoolS ?value) - (|do [_ (&type/check value-type &type/Bool) - =kont kont] - (return (&/T [($BoolTestAC ?value) =kont]))) - - (&/$NatS ?value) - (|do [_ (&type/check value-type &type/Nat) - =kont kont] - (return (&/T [($NatTestAC ?value) =kont]))) - - (&/$IntS ?value) - (|do [_ (&type/check value-type &type/Int) - =kont kont] - (return (&/T [($IntTestAC ?value) =kont]))) - - (&/$FracS ?value) - (|do [_ (&type/check value-type &type/Frac) - =kont kont] - (return (&/T [($FracTestAC ?value) =kont]))) - - (&/$RealS ?value) - (|do [_ (&type/check value-type &type/Real) - =kont kont] - (return (&/T [($RealTestAC ?value) =kont]))) - - (&/$CharS ?value) - (|do [_ (&type/check value-type &type/Char) - =kont kont] - (return (&/T [($CharTestAC ?value) =kont]))) - - (&/$TextS ?value) - (|do [_ (&type/check value-type &type/Text) - =kont kont] - (return (&/T [($TextTestAC ?value) =kont]))) - - (&/$TupleS ?members) - (|case ?members - (&/$Nil) - (|do [_ (&type/check value-type &/$UnitT) - =kont kont] - (return (&/T [($TupleTestAC (&/|list)) =kont]))) - - (&/$Cons ?member (&/$Nil)) - (analyse-pattern var?? value-type ?member kont) - - _ - (|do [must-infer? (&type/unknown? value-type) - value-type* (if must-infer? - (|do [member-types (&/map% (fn [_] &type/create-var+) (&/|range (&/|length ?members)))] - (return (&type/fold-prod member-types))) - (adjust-type value-type))] - (|case value-type* - (&/$ProdT _) - (|let [num-elems (&/|length ?members) - [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?members) value-type*)] - (if (= num-elems _shorter) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern &/$None v m kont*)] - (return (&/T [(&/$Cons =test =tests) =kont]))))) - (|do [=kont kont] - (return (&/T [&/$Nil =kont]))) - (&/|reverse (&/zip2 _tuple-types ?members)))] - (return (&/T [($TupleTestAC =tests) =kont]))) - (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?members) "]" - " -- " (&/show-ast pattern) - " " (&type/show-type value-type*) " " (&type/show-type value-type))))) - - _ - (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type)))))) - - (&/$RecordS pairs) - (|do [[rec-members rec-type] (&&record/order-record pairs) - must-infer? (&type/unknown? value-type) - rec-type* (if must-infer? - (&type/instantiate-inference rec-type) - (return value-type)) - _ (&type/check value-type rec-type*)] - (analyse-pattern &/$None rec-type* (&/T [meta (&/$TupleS rec-members)]) kont)) - - (&/$TagS ?ident) - (|do [[=module =name] (&&/resolved-ident ?ident) - must-infer? (&type/unknown? value-type) - variant-type (if must-infer? - (|do [variant-type (&module/tag-type =module =name) - variant-type* (&type/instantiate-inference variant-type) - _ (&type/check value-type variant-type*)] - (return variant-type*)) - (return value-type)) - value-type* (adjust-type variant-type) - idx (&module/tag-index =module =name) - group (&module/tag-group =module =name) - case-type (&type/sum-at idx value-type*) - [=test =kont] (analyse-pattern &/$None case-type unit-tuple kont)] - (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) - - (&/$FormS (&/$Cons [_ (&/$NatS idx)] ?values)) - (|do [value-type* (adjust-type value-type) - case-type (&type/sum-at idx value-type*) - [=test =kont] (case (int (&/|length ?values)) - 0 (analyse-pattern &/$None case-type unit-tuple kont) - 1 (analyse-pattern &/$None case-type (&/|head ?values) kont) - ;; 1+ - (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$TupleS ?values)]) kont))] - (return (&/T [($VariantTestAC (&/T [idx (&/|length (&type/flatten-sum value-type*)) =test])) =kont]))) - - (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) - (|do [[=module =name] (&&/resolved-ident ?ident) - must-infer? (&type/unknown? value-type) - variant-type (if must-infer? - (|do [variant-type (&module/tag-type =module =name) - variant-type* (&type/instantiate-inference variant-type) - _ (&type/check value-type variant-type*)] - (return variant-type*)) - (return value-type)) - value-type* (adjust-type variant-type) - idx (&module/tag-index =module =name) - group (&module/tag-group =module =name) - case-type (&type/sum-at idx value-type*) - [=test =kont] (case (int (&/|length ?values)) - 0 (analyse-pattern &/$None case-type unit-tuple kont) - 1 (analyse-pattern &/$None case-type (&/|head ?values) kont) - ;; 1+ - (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$TupleS ?values)]) kont))] - (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) - - _ - (fail (str "[Pattern-matching Error] Unrecognized pattern syntax: " (&/show-ast pattern))) - ))) - -(defn ^:private analyse-branch [analyse exo-type var?? value-type pattern body patterns] - (|do [pattern+body (analyse-pattern var?? value-type pattern - (&&/analyse-1 analyse exo-type body))] - (return (&/$Cons pattern+body patterns)))) - -(defn ^:private merge-total [struct test+body] - (|let [[test ?body] test+body] - (|case [struct test] - [($DefaultTotal total?) ($NoTestAC)] - (return ($DefaultTotal true)) - - [($BoolTotal total? ?values) ($NoTestAC)] - (return ($BoolTotal true ?values)) - - [($NatTotal total? ?values) ($NoTestAC)] - (return ($NatTotal true ?values)) - - [($IntTotal total? ?values) ($NoTestAC)] - (return ($IntTotal true ?values)) - - [($FracTotal total? ?values) ($NoTestAC)] - (return ($FracTotal true ?values)) - - [($RealTotal total? ?values) ($NoTestAC)] - (return ($RealTotal true ?values)) - - [($CharTotal total? ?values) ($NoTestAC)] - (return ($CharTotal true ?values)) - - [($TextTotal total? ?values) ($NoTestAC)] - (return ($TextTotal true ?values)) - - [($TupleTotal total? ?values) ($NoTestAC)] - (return ($TupleTotal true ?values)) - - [($VariantTotal total? ?values) ($NoTestAC)] - (return ($VariantTotal true ?values)) - - [($DefaultTotal total?) ($StoreTestAC ?idx)] - (return ($DefaultTotal true)) - - [($BoolTotal total? ?values) ($StoreTestAC ?idx)] - (return ($BoolTotal true ?values)) - - [($NatTotal total? ?values) ($StoreTestAC ?idx)] - (return ($NatTotal true ?values)) - - [($IntTotal total? ?values) ($StoreTestAC ?idx)] - (return ($IntTotal true ?values)) - - [($FracTotal total? ?values) ($StoreTestAC ?idx)] - (return ($FracTotal true ?values)) - - [($RealTotal total? ?values) ($StoreTestAC ?idx)] - (return ($RealTotal true ?values)) - - [($CharTotal total? ?values) ($StoreTestAC ?idx)] - (return ($CharTotal true ?values)) - - [($TextTotal total? ?values) ($StoreTestAC ?idx)] - (return ($TextTotal true ?values)) - - [($TupleTotal total? ?values) ($StoreTestAC ?idx)] - (return ($TupleTotal true ?values)) - - [($VariantTotal total? ?values) ($StoreTestAC ?idx)] - (return ($VariantTotal true ?values)) - - [($DefaultTotal total?) ($BoolTestAC ?value)] - (return ($BoolTotal total? (&/|list ?value))) - - [($BoolTotal total? ?values) ($BoolTestAC ?value)] - (return ($BoolTotal total? (&/$Cons ?value ?values))) - - [($DefaultTotal total?) ($NatTestAC ?value)] - (return ($NatTotal total? (&/|list ?value))) - - [($NatTotal total? ?values) ($NatTestAC ?value)] - (return ($NatTotal total? (&/$Cons ?value ?values))) - - [($DefaultTotal total?) ($IntTestAC ?value)] - (return ($IntTotal total? (&/|list ?value))) - - [($IntTotal total? ?values) ($IntTestAC ?value)] - (return ($IntTotal total? (&/$Cons ?value ?values))) - - [($DefaultTotal total?) ($FracTestAC ?value)] - (return ($FracTotal total? (&/|list ?value))) - - [($FracTotal total? ?values) ($FracTestAC ?value)] - (return ($FracTotal total? (&/$Cons ?value ?values))) - - [($DefaultTotal total?) ($RealTestAC ?value)] - (return ($RealTotal total? (&/|list ?value))) - - [($RealTotal total? ?values) ($RealTestAC ?value)] - (return ($RealTotal total? (&/$Cons ?value ?values))) - - [($DefaultTotal total?) ($CharTestAC ?value)] - (return ($CharTotal total? (&/|list ?value))) - - [($CharTotal total? ?values) ($CharTestAC ?value)] - (return ($CharTotal total? (&/$Cons ?value ?values))) - - [($DefaultTotal total?) ($TextTestAC ?value)] - (return ($TextTotal total? (&/|list ?value))) - - [($TextTotal total? ?values) ($TextTestAC ?value)] - (return ($TextTotal total? (&/$Cons ?value ?values))) - - [($DefaultTotal total?) ($TupleTestAC ?tests)] - (|do [structs (&/map% (fn [t] - (merge-total ($DefaultTotal total?) (&/T [t ?body]))) - ?tests)] - (return ($TupleTotal total? structs))) - - [($TupleTotal total? ?values) ($TupleTestAC ?tests)] - (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) - (|do [structs (&/map2% (fn [v t] - (merge-total v (&/T [t ?body]))) - ?values ?tests)] - (return ($TupleTotal total? structs))) - (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - - [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] - (|do [sub-struct (merge-total ($DefaultTotal total?) - (&/T [?test ?body])) - structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count ($DefaultTotal total?))) - (&/$Some list) - (return list) - - (&/$None) - (fail "[Pattern-matching Error] YOLO"))] - (return ($VariantTotal total? structs))) - - [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] - (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) - (&/$Some sub) - sub - - (&/$None) - ($DefaultTotal total?)) - (&/T [?test ?body])) - structs (|case (&/|list-put ?tag sub-struct ?branches) - (&/$Some list) - (return list) - - (&/$None) - (fail "[Pattern-matching Error] YOLO"))] - (return ($VariantTotal total? structs))) - ))) - -(defn check-totality+ [check-totality] - (fn [?token] - (&type/with-var - (fn [$var] - (|do [=output (check-totality $var ?token) - ?type (&type/deref+ $var) - =type (&type/clean $var ?type)] - (return (&/T [=output =type]))))))) - -(defn ^:private check-totality [value-type struct] - (|case struct - ($DefaultTotal ?total) - (return ?total) - - ($BoolTotal ?total ?values) - (|do [_ (&type/check value-type &type/Bool)] - (return (or ?total - (= #{true false} (set (&/->seq ?values)))))) - - ($NatTotal ?total _) - (|do [_ (&type/check value-type &type/Nat)] - (return ?total)) - - ($IntTotal ?total _) - (|do [_ (&type/check value-type &type/Int)] - (return ?total)) - - ($FracTotal ?total _) - (|do [_ (&type/check value-type &type/Frac)] - (return ?total)) - - ($RealTotal ?total _) - (|do [_ (&type/check value-type &type/Real)] - (return ?total)) - - ($CharTotal ?total _) - (|do [_ (&type/check value-type &type/Char)] - (return ?total)) - - ($TextTotal ?total _) - (|do [_ (&type/check value-type &type/Text)] - (return ?total)) - - ($TupleTotal ?total ?structs) - (|case ?structs - (&/$Nil) - (|do [value-type* (resolve-type value-type)] - (|case value-type* - (&/$UnitT) - (return true) - - _ - (fail "[Pattern-maching Error] Unit is not total."))) - - _ - (|do [unknown? (&type/unknown? value-type)] - (if unknown? - (|do [=structs (&/map% (check-totality+ check-totality) ?structs) - _ (&type/check value-type (|case (->> (&/|map &/|second =structs) (&/|reverse)) - (&/$Cons last prevs) - (&/fold (fn [right left] (&/$ProdT left right)) - last prevs)))] - (return (or ?total - (&/fold #(and %1 %2) true (&/|map &/|first =structs))))) - (if ?total - (return true) - (|do [value-type* (resolve-type value-type)] - (|case value-type* - (&/$ProdT _) - (|let [num-elems (&/|length ?structs) - [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?structs) value-type*)] - (if (= num-elems _shorter) - (|do [totals (&/map2% check-totality _tuple-types ?structs)] - (return (&/fold #(and %1 %2) true totals))) - (fail (str "[Pattern-maching Error] Tuple-mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?structs) "]")))) - - _ - (fail (str "[Pattern-maching Error] Tuple is not total." " - " (&type/show-type value-type*))))))))) - - ($VariantTotal ?total ?structs) - (if ?total - (return true) - (|do [value-type* (resolve-type value-type)] - (|case value-type* - (&/$SumT _) - (|do [totals (&/map2% check-totality - (&type/flatten-sum value-type*) - ?structs)] - (return (&/fold #(and %1 %2) true totals))) - - _ - (fail "[Pattern-maching Error] Variant is not total.")))) - )) - -;; [Exports] -(defn analyse-branches [analyse exo-type var?? value-type branches] - (|do [patterns (&/fold% (fn [patterns branch] - (|let [[pattern body] branch] - (analyse-branch analyse exo-type var?? value-type pattern body patterns))) - &/$Nil - branches) - struct (&/fold% merge-total ($DefaultTotal false) patterns) - ? (check-totality value-type struct)] - (if ? - (return patterns) - (fail "[Pattern-maching Error] Pattern-matching is non-total.")))) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj deleted file mode 100644 index 75e066e34..000000000 --- a/src/lux/analyser/env.clj +++ /dev/null @@ -1,74 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.analyser.env - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail* |case]]) - [lux.analyser.base :as &&])) - -;; [Exports] -(def next-local-idx - (fn [state] - (return* state (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) - -(defn with-local [name type body] - (fn [state] - (let [old-mappings (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) - =return (body (&/update$ &/$scopes - (fn [stack] - (let [var-analysis (&&/|meta type &/empty-cursor (&&/$var (&/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter)))))] - (&/$Cons (&/update$ &/$locals #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [m] (&/|put name var-analysis m)))) - (&/|head stack)) - (&/|tail stack)))) - state))] - (|case =return - (&/$Right ?state ?value) - (return* (&/update$ &/$scopes (fn [stack*] - (&/$Cons (&/update$ &/$locals #(->> % - (&/update$ &/$counter dec) - (&/set$ &/$mappings old-mappings)) - (&/|head stack*)) - (&/|tail stack*))) - ?state) - ?value) - - _ - =return)))) - -(defn with-alias [name var-analysis body] - (fn [state] - (let [old-mappings (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) - =return (body (&/update$ &/$scopes - (fn [stack] - (&/$Cons (&/update$ &/$locals #(->> % - (&/update$ &/$mappings (fn [m] (&/|put name var-analysis m)))) - (&/|head stack)) - (&/|tail stack))) - state))] - (|case =return - (&/$Right ?state ?value) - (return* (&/update$ &/$scopes (fn [stack*] - (&/$Cons (&/update$ &/$locals #(->> % - (&/set$ &/$mappings old-mappings)) - (&/|head stack*)) - (&/|tail stack*))) - ?state) - ?value) - - _ - =return)))) - -(def captured-vars - (fn [state] - (|case (&/get$ &/$scopes state) - (&/$Nil) - (fail* "[Analyser Error] Can't obtain captured vars without environments.") - - (&/$Cons env _) - (return* state (->> env (&/get$ &/$closure) (&/get$ &/$mappings)))) - )) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj deleted file mode 100644 index 209e36d0e..000000000 --- a/src/lux/analyser/host.clj +++ /dev/null @@ -1,1379 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.analyser.host - (:require (clojure [template :refer [do-template]] - [string :as string]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case assert!]] - [type :as &type] - [host :as &host] - [lexer :as &lexer] - [parser :as &parser] - [reader :as &reader]) - [lux.type.host :as &host-type] - [lux.host.generics :as &host-generics] - (lux.analyser [base :as &&] - [lambda :as &&lambda] - [env :as &&env] - [parser :as &&a-parser]) - [lux.compiler.base :as &c!base]) - (:import (java.lang.reflect Type TypeVariable))) - -;; [Utils] -(defn ^:private ensure-catching [exceptions*] - "(-> (List Text) (Lux Null))" - (|do [class-loader &/loader] - (fn [state] - (|let [exceptions (&/|map #(Class/forName % true class-loader) exceptions*) - catching (->> state - (&/get$ &/$host) - (&/get$ &/$catching) - (&/|map #(Class/forName % true class-loader)))] - (if-let [missing-ex (&/fold (fn [prev ^Class now] - (or prev - (cond (or (.isAssignableFrom java.lang.RuntimeException now) - (.isAssignableFrom java.lang.Error now)) - nil - - (&/fold (fn [found? ^Class ex-catch] - (or found? - (.isAssignableFrom ex-catch now))) - false - catching) - nil - - :else - now))) - nil - exceptions)] - ((&/fail-with-loc (str "[Analyser Error] Unhandled exception: " missing-ex)) - state) - (&/return* state nil))) - ))) - -(defn ^:private with-catches [catches body] - "(All [a] (-> (List Text) (Lux a) (Lux a)))" - (fn [state] - (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) - state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))] - (|case (&/run-state body state*) - (&/$Left msg) - (&/$Left msg) - - (&/$Right state** output) - (&/$Right (&/T [(->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) - output])))) - )) - -(defn ^:private ensure-object [type] - "(-> Type (Lux (, Text (List Type))))" - (|case type - (&/$HostT payload) - (return payload) - - (&/$VarT id) - (return (&/T ["java.lang.Object" (&/|list)])) - - (&/$ExT id) - (return (&/T ["java.lang.Object" (&/|list)])) - - (&/$NamedT _ type*) - (ensure-object type*) - - (&/$UnivQ _ type*) - (ensure-object type*) - - (&/$ExQ _ type*) - (ensure-object type*) - - (&/$AppT F A) - (|do [type* (&type/apply-type F A)] - (ensure-object type*)) - - _ - (&/fail-with-loc (str "[Analyser Error] Expecting object: " (&type/show-type type))))) - -(defn ^:private as-object [type] - "(-> Type Type)" - (|case type - (&/$HostT class params) - (&/$HostT (&host-type/as-obj class) params) - - _ - type)) - -(defn ^:private as-otype [tname] - (case tname - "boolean" "java.lang.Boolean" - "byte" "java.lang.Byte" - "short" "java.lang.Short" - "int" "java.lang.Integer" - "long" "java.lang.Long" - "float" "java.lang.Float" - "double" "java.lang.Double" - "char" "java.lang.Character" - ;; else - tname - )) - -(defn ^:private as-otype+ [type] - "(-> Type Type)" - (|case type - (&/$HostT name params) - (&/$HostT (as-otype name) params) - - _ - type)) - -(defn ^:private clean-gtype-var [idx gtype-var] - (|let [(&/$VarT id) gtype-var] - (|do [? (&type/bound? id)] - (if ? - (|do [real-type (&type/deref id)] - (return (&/T [idx real-type]))) - (return (&/T [(+ 2 idx) (&/$BoundT idx)])))))) - -(defn ^:private clean-gtype-vars [gtype-vars] - (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] - (|do [:let [[idx types] idx+types] - [idx* real-type] (clean-gtype-var idx gtype-var)] - (return (&/T [idx* (&/$Cons real-type types)])))) - (&/T [1 &/$Nil]) - gtype-vars)] - (return clean-types))) - -(defn ^:private make-gtype [class-name type-args] - "(-> Text (List Type) Type)" - (&/fold (fn [base-type type-arg] - (|case type-arg - (&/$BoundT _) - (&/$UnivQ &type/empty-env base-type) - - _ - base-type)) - (&/$HostT class-name type-args) - type-args)) - -;; [Resources] -(defn ^:private analyse-field-access-helper [obj-type gvars gtype] - "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" - (|case obj-type - (&/$HostT class targs) - (if (= (&/|length targs) (&/|length gvars)) - (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) - (&/|table) - gvars - targs)] - (&host-type/instance-param &type/existential gtype-env gtype)) - (&/fail-with-loc (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) - - _ - (&/fail-with-loc (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) - -(defn generic-class->simple-class [gclass] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericTypeVar var-name) - "java.lang.Object" - - (&/$GenericWildcard _) - "java.lang.Object" - - (&/$GenericClass name params) - name - - (&/$GenericArray param) - (|case param - (&/$GenericArray _) - (str "[" (generic-class->simple-class param)) - - (&/$GenericClass "boolean" _) - "[Z" - - (&/$GenericClass "byte" _) - "[B" - - (&/$GenericClass "short" _) - "[S" - - (&/$GenericClass "int" _) - "[I" - - (&/$GenericClass "long" _) - "[J" - - (&/$GenericClass "float" _) - "[F" - - (&/$GenericClass "double" _) - "[D" - - (&/$GenericClass "char" _) - "[C" - - (&/$GenericClass name params) - (str "[L" name ";") - - (&/$GenericTypeVar var-name) - "[Ljava.lang.Object;" - - (&/$GenericWildcard _) - "[Ljava.lang.Object;") - )) - -(defn generic-class->type [env gclass] - "(-> (List (, TypeVar Type)) GenericClass (Lux Type))" - (|case gclass - (&/$GenericTypeVar var-name) - (if-let [ex (&/|get var-name env)] - (return ex) - (&/fail-with-loc (str "[Analysis Error] Unknown type var: " var-name))) - - (&/$GenericClass name params) - (case name - "boolean" (return (&/$HostT "java.lang.Boolean" &/$Nil)) - "byte" (return (&/$HostT "java.lang.Byte" &/$Nil)) - "short" (return (&/$HostT "java.lang.Short" &/$Nil)) - "int" (return (&/$HostT "java.lang.Integer" &/$Nil)) - "long" (return (&/$HostT "java.lang.Long" &/$Nil)) - "float" (return (&/$HostT "java.lang.Float" &/$Nil)) - "double" (return (&/$HostT "java.lang.Double" &/$Nil)) - "char" (return (&/$HostT "java.lang.Character" &/$Nil)) - "void" (return &/$UnitT) - ;; else - (|do [=params (&/map% (partial generic-class->type env) params)] - (return (&/$HostT name =params)))) - - (&/$GenericArray param) - (|do [=param (generic-class->type env param)] - (return (&/$HostT &host-type/array-data-tag (&/|list =param)))) - - (&/$GenericWildcard _) - (return (&/$ExQ &/$Nil (&/$BoundT 1))) - )) - -(defn gen-super-env [class-env supers class-decl] - "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))" - (|let [[class-name class-vars] class-decl] - (|case (&/|some (fn [super] - (|let [[super-name super-params] super] - (if (= class-name super-name) - (&/$Some (&/zip2 (&/|map &/|first class-vars) super-params)) - &/$None))) - supers) - (&/$None) - (&/fail-with-loc (str "[Analyser Error] Unrecognized super-class: " class-name)) - - (&/$Some vars+gtypes) - (&/map% (fn [var+gtype] - (|do [:let [[var gtype] var+gtype] - =gtype (generic-class->type class-env gtype)] - (return (&/T [var =gtype])))) - vars+gtypes) - ))) - -(defn ^:private make-type-env [type-params] - "(-> (List TypeParam) (Lux (List [Text Type])))" - (&/map% (fn [gvar] - (|do [:let [[gvar-name _] gvar] - ex &type/existential] - (return (&/T [gvar-name ex])))) - type-params)) - -(defn ^:private double-register-gclass? [gclass] - (|case gclass - (&/$GenericClass name _) - (|case name - "long" true - "double" true - _ false) - - _ - false)) - -(defn ^:private method-input-folder [full-env] - (fn [body* input*] - (|do [:let [[iname itype*] input*] - itype (generic-class->type full-env itype*)] - (if (double-register-gclass? itype*) - (&&env/with-local iname itype - (&&env/with-local "" &/$VoidT - body*)) - (&&env/with-local iname itype - body*))))) - -(defn ^:private analyse-method [analyse class-decl class-env all-supers method] - "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" - (|let [[?cname ?cparams] class-decl - class-type (&/$HostT ?cname (&/|map &/|second class-env))] - (|case method - (&/$ConstructorMethodSyntax =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env (&/|++ class-env method-env)] - :let [output-type &/$UnitT] - =ctor-args (&/map% (fn [ctor-arg] - (|do [:let [[ca-type ca-term] ctor-arg] - =ca-type (generic-class->type full-env ca-type) - =ca-term (&&/analyse-1 analyse =ca-type ca-term)] - (return (&/T [ca-type =ca-term])))) - ?ctor-args) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))))] - (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) - - (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env (&/|++ class-env method-env)] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))))] - (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$OverridenMethodSyntax ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [super-env (gen-super-env class-env all-supers ?class-decl) - method-env (make-type-env ?gvars) - :let [full-env (&/|++ super-env method-env)] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))))] - (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$StaticMethodSyntax ?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env method-env] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs)))))] - (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$AbstractMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (return (&/$AbstractMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) - - (&/$NativeMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (return (&/$NativeMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) - ))) - -(defn ^:private mandatory-methods [supers] - (|do [class-loader &/loader] - (&/flat-map% (partial &host/abstract-methods class-loader) supers))) - -(defn ^:private check-method-completion [supers methods] - "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux Null))" - (|do [abstract-methods (mandatory-methods supers) - :let [methods-map (&/fold (fn [mmap mentry] - (|case mentry - (&/$ConstructorMethodAnalysis _) - mmap - - (&/$VirtualMethodAnalysis _) - mmap - - (&/$OverridenMethodAnalysis =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) - (update-in mmap [=name] (fn [old-inputs] (if old-inputs (conj old-inputs =inputs) [=inputs]))) - - (&/$StaticMethodAnalysis _) - mmap - - (&/$AbstractMethodSyntax _) - mmap - - (&/$NativeMethodSyntax _) - mmap - )) - {} - methods) - missing-method (&/fold (fn [missing abs-meth] - (or missing - (|let [[am-name am-inputs] abs-meth] - (if-let [meth-struct (get methods-map am-name)] - (if (some (fn [=inputs] - (and (= (&/|length =inputs) (&/|length am-inputs)) - (&/fold2 (fn [prev mi ai] - (|let [[iname itype] mi] - (and prev (= (generic-class->simple-class itype) ai)))) - true - =inputs am-inputs))) - meth-struct) - nil - abs-meth) - abs-meth)))) - nil - abstract-methods)]] - (if (nil? missing-method) - (return nil) - (|let [[am-name am-inputs] missing-method] - (&/fail-with-loc (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) - -(defn ^:private analyse-field [analyse gtype-env field] - "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))" - (|case field - (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) - (|do [=gtype (&host-type/instance-gtype &type/existential gtype-env ?gclass) - =value (&&/analyse-1 analyse =gtype ?value)] - (return (&/$ConstantFieldAnalysis ?name ?anns ?gclass =value))) - - (&/$VariableFieldSyntax ?name ?privacy-modifier ?state-modifier ?anns ?type) - (return (&/$VariableFieldAnalysis ?name ?privacy-modifier ?state-modifier ?anns ?type)) - )) - -(do-template [ ] - (let [output-type (&/$HostT &/$Nil)] - (defn [analyse exo-type _?value] - (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] - =value (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value) (&/|list)))))))) - - ^:private analyse-jvm-d2f "d2f" "java.lang.Double" "java.lang.Float" - ^:private analyse-jvm-d2i "d2i" "java.lang.Double" "java.lang.Integer" - ^:private analyse-jvm-d2l "d2l" "java.lang.Double" "java.lang.Long" - - ^:private analyse-jvm-f2d "f2d" "java.lang.Float" "java.lang.Double" - ^:private analyse-jvm-f2i "f2i" "java.lang.Float" "java.lang.Integer" - ^:private analyse-jvm-f2l "f2l" "java.lang.Float" "java.lang.Long" - - ^:private analyse-jvm-i2b "i2b" "java.lang.Integer" "java.lang.Byte" - ^:private analyse-jvm-i2c "i2c" "java.lang.Integer" "java.lang.Character" - ^:private analyse-jvm-i2d "i2d" "java.lang.Integer" "java.lang.Double" - ^:private analyse-jvm-i2f "i2f" "java.lang.Integer" "java.lang.Float" - ^:private analyse-jvm-i2l "i2l" "java.lang.Integer" "java.lang.Long" - ^:private analyse-jvm-i2s "i2s" "java.lang.Integer" "java.lang.Short" - - ^:private analyse-jvm-l2d "l2d" "java.lang.Long" "java.lang.Double" - ^:private analyse-jvm-l2f "l2f" "java.lang.Long" "java.lang.Float" - ^:private analyse-jvm-l2i "l2i" "java.lang.Long" "java.lang.Integer" - ^:private analyse-jvm-l2s "l2i" "java.lang.Long" "java.lang.Short" - ^:private analyse-jvm-l2b "l2i" "java.lang.Long" "java.lang.Byte" - - ^:private analyse-jvm-c2b "c2b" "java.lang.Character" "java.lang.Byte" - ^:private analyse-jvm-c2s "c2s" "java.lang.Character" "java.lang.Short" - ^:private analyse-jvm-c2i "c2i" "java.lang.Character" "java.lang.Integer" - ^:private analyse-jvm-c2l "c2l" "java.lang.Character" "java.lang.Long" - - ^:private analyse-jvm-s2l "s2l" "java.lang.Short" "java.lang.Long" - - ^:private analyse-jvm-b2l "b2l" "java.lang.Byte" "java.lang.Long" - ) - -(do-template [ ] - (let [output-type (&/$HostT &/$Nil)] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons ?value1 (&/$Cons ?value2 (&/$Nil))) ?values] - =value1 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value1) - =value2 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value2) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value1 =value2) (&/|list)))))))) - - ^:private analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ixor "ixor" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ishl "ishl" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ishr "ishr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-iushr "iushr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - - ^:private analyse-jvm-land "land" "java.lang.Long" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lor "lor" "java.lang.Long" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lxor "lxor" "java.lang.Long" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lshl "lshl" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ^:private analyse-jvm-lshr "lshr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ^:private analyse-jvm-lushr "lushr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ) - -(do-template [ ] - (let [input-type (&/$HostT &/$Nil) - output-type (&/$HostT &/$Nil)] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse input-type x) - =y (&&/analyse-1 analyse input-type y) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =x =y) (&/|list)))))))) - - ^:private analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-imul "imul" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-idiv "idiv" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-irem "irem" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ieq "ieq" "java.lang.Integer" "java.lang.Boolean" - ^:private analyse-jvm-ilt "ilt" "java.lang.Integer" "java.lang.Boolean" - ^:private analyse-jvm-igt "igt" "java.lang.Integer" "java.lang.Boolean" - - ^:private analyse-jvm-ceq "ceq" "java.lang.Character" "java.lang.Boolean" - ^:private analyse-jvm-clt "clt" "java.lang.Character" "java.lang.Boolean" - ^:private analyse-jvm-cgt "cgt" "java.lang.Character" "java.lang.Boolean" - - ^:private analyse-jvm-ladd "ladd" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lsub "lsub" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lmul "lmul" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-ldiv "ldiv" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lrem "lrem" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-leq "leq" "java.lang.Long" "java.lang.Boolean" - ^:private analyse-jvm-llt "llt" "java.lang.Long" "java.lang.Boolean" - ^:private analyse-jvm-lgt "lgt" "java.lang.Long" "java.lang.Boolean" - - ^:private analyse-jvm-fadd "fadd" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-fsub "fsub" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-fmul "fmul" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-fdiv "fdiv" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-frem "frem" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-feq "feq" "java.lang.Float" "java.lang.Boolean" - ^:private analyse-jvm-flt "flt" "java.lang.Float" "java.lang.Boolean" - ^:private analyse-jvm-fgt "fgt" "java.lang.Float" "java.lang.Boolean" - - ^:private analyse-jvm-dadd "dadd" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-dsub "dsub" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-dmul "dmul" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-ddiv "ddiv" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-drem "drem" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-deq "deq" "java.lang.Double" "java.lang.Boolean" - ^:private analyse-jvm-dlt "dlt" "java.lang.Double" "java.lang.Boolean" - ^:private analyse-jvm-dgt "dgt" "java.lang.Double" "java.lang.Boolean" - ) - -(let [length-type &type/Nat - idx-type &type/Nat] - (do-template [ ] - (let [elem-type (&/$HostT &/$Nil) - array-type (&/$HostT &/$Nil)] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons length (&/$Nil)) ?values] - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =length) (&/|list))))))) - - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type elem-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx) (&/|list))))))) - - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] - =array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse elem-type elem) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx =elem) (&/|list))))))) - ) - - "java.lang.Boolean" "[Z" ^:private analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore" - "java.lang.Byte" "[B" ^:private analyse-jvm-bnewarray "bnewarray" analyse-jvm-baload "baload" analyse-jvm-bastore "bastore" - "java.lang.Short" "[S" ^:private analyse-jvm-snewarray "snewarray" analyse-jvm-saload "saload" analyse-jvm-sastore "sastore" - "java.lang.Integer" "[I" ^:private analyse-jvm-inewarray "inewarray" analyse-jvm-iaload "iaload" analyse-jvm-iastore "iastore" - "java.lang.Long" "[J" ^:private analyse-jvm-lnewarray "lnewarray" analyse-jvm-laload "laload" analyse-jvm-lastore "lastore" - "java.lang.Float" "[F" ^:private analyse-jvm-fnewarray "fnewarray" analyse-jvm-faload "faload" analyse-jvm-fastore "fastore" - "java.lang.Double" "[D" ^:private analyse-jvm-dnewarray "dnewarray" analyse-jvm-daload "daload" analyse-jvm-dastore "dastore" - "java.lang.Character" "[C" ^:private analyse-jvm-cnewarray "cnewarray" analyse-jvm-caload "caload" analyse-jvm-castore "castore" - )) - -(defn ^:private array-class? [class-name] - (or (= &host-type/array-data-tag class-name) - (case class-name - ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") true - ;; else - false))) - -(let [length-type &type/Nat - idx-type &type/Nat] - (defn ^:private analyse-jvm-anewarray [analyse exo-type ?values] - (|do [:let [(&/$Cons [_ (&/$TextS _gclass)] (&/$Cons length (&/$Nil))) ?values] - gclass (&reader/with-source "jvm-anewarray" _gclass - &&a-parser/parse-gclass) - gtype-env &/get-type-env - =gclass (&host-type/instance-gtype &type/existential gtype-env gclass) - :let [array-type (&/$HostT &host-type/array-data-tag (&/|list =gclass))] - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) - - (defn ^:private analyse-jvm-aaload [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type inner-arr-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list))))))) - - (defn ^:private analyse-jvm-aastore [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] - =array (&&/analyse-1+ analyse array) - :let [array-type (&&/expr-type* =array)] - [arr-class arr-params] (ensure-object array-type) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse inner-arr-type elem) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) - -(defn ^:private analyse-jvm-arraylength [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Nil)) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list)) - ))))) - -(defn ^:private analyse-jvm-null? [analyse exo-type ?values] - (|do [:let [(&/$Cons object (&/$Nil)) ?values] - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - :let [output-type &type/Bool] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "null?"]) (&/|list =object) (&/|list))))))) - -(defn ^:private analyse-jvm-null [analyse exo-type ?values] - (|do [:let [(&/$Nil) ?values] - :let [output-type (&/$HostT &host-type/null-data-tag &/$Nil)] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list))))))) - -(defn analyse-jvm-synchronized [analyse exo-type ?values] - (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values] - =monitor (&&/analyse-1+ analyse ?monitor) - _ (ensure-object (&&/expr-type* =monitor)) - =expr (&&/analyse-1 analyse exo-type ?expr) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "synchronized"]) (&/|list =monitor =expr) (&/|list))))))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons ?monitor (&/$Nil)) ?values] - =monitor (&&/analyse-1+ analyse ?monitor) - _ (ensure-object (&&/expr-type* =monitor)) - :let [output-type &/$UnitT] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =monitor) (&/|list))))))) - - ^:private analyse-jvm-monitorenter "monitorenter" - ^:private analyse-jvm-monitorexit "monitorexit" - ) - -(defn ^:private analyse-jvm-throw [analyse exo-type ?values] - (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values] - =ex (&&/analyse-1+ analyse ?ex) - _ (&type/check (&/$HostT "java.lang.Throwable" &/$Nil) (&&/expr-type* =ex)) - [throw-class throw-params] (ensure-object (&&/expr-type* =ex)) - _ (ensure-catching (&/|list throw-class)) - _cursor &/cursor - _ (&type/check exo-type &type/Bottom)] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list))))))) - -(defn ^:private analyse-jvm-getstatic [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Nil) ?values] - class-loader &/loader - [gvars gtype] (&host/lookup-static-field class-loader !class! field) - =type (&host-type/instance-param &type/existential &/$Nil gtype) - :let [output-type =type] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type))))))) - -(defn ^:private analyse-jvm-getfield [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons object (&/$Nil)) ?values] - class-loader &/loader - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - [gvars gtype] (&host/lookup-field class-loader !class! field) - =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) - :let [output-type =type] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type))))))) - -(defn ^:private analyse-jvm-putstatic [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons value (&/$Nil)) ?values] - class-loader &/loader - [gvars gtype] (&host/lookup-static-field class-loader !class! field) - :let [gclass (&host-type/gtype->gclass gtype)] - =type (&host-type/instance-param &type/existential &/$Nil gtype) - =value (&&/analyse-1 analyse =type value) - :let [output-type &/$UnitT] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass))))))) - -(defn ^:private analyse-jvm-putfield [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values] - class-loader &/loader - =object (&&/analyse-1+ analyse object) - :let [obj-type (&&/expr-type* =object)] - _ (ensure-object obj-type) - [gvars gtype] (&host/lookup-field class-loader !class! field) - :let [gclass (&host-type/gtype->gclass gtype)] - =type (analyse-field-access-helper obj-type gvars gtype) - =value (&&/analyse-1 analyse =type value) - :let [output-type &/$UnitT] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type))))))) - -(defn ^:private analyse-method-call-helper [analyse exo-type gret gtype-env gtype-vars gtype-args args] - (|case gtype-vars - (&/$Nil) - (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - =arg-types (&/map% &type/show-type+ arg-types) - =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) - =gret (&host-type/instance-param &type/existential gtype-env gret) - _ (&type/check exo-type (as-otype+ =gret))] - (return (&/T [=gret =args]))) - - (&/$Cons ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|do [:let [(&/$VarT _id) $var - gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] - [=gret =args] (analyse-method-call-helper analyse exo-type gret gtype-env* gtype-vars* gtype-args args) - ==gret (&type/clean $var =gret) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (return (&/T [==gret ==args]))))) - )) - -(let [dummy-type-param (&/$HostT "java.lang.Object" &/$Nil)] - (do-template [ ] - (defn [analyse exo-type class method classes ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons object args) ?values] - class-loader &/loader - _ (try (assert! (let [=class (Class/forName !class! true class-loader)] - (= (.isInterface =class))) - (if - (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") - (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) - (catch Exception e - (&/fail-with-loc (str "[Analyser Error] Unknown class: " class)))) - [gret exceptions parent-gvars gvars gargs] (if (= "" method) - (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) - (&host/lookup-virtual-method class-loader !class! method classes)) - _ (ensure-catching exceptions) - =object (&&/analyse-1+ analyse object) - [sub-class sub-params] (ensure-object (&&/expr-type* =object)) - (&/$HostT super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class) - !class! - sub-class) - sub-params) - :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) - (&/|table) - parent-gvars - super-params*)] - [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/$Cons =object =args) (&/|list class method classes output-type gret))))))) - - ^:private analyse-jvm-invokevirtual "invokevirtual" false - ^:private analyse-jvm-invokespecial "invokespecial" false - ^:private analyse-jvm-invokeinterface "invokeinterface" true - )) - -(defn ^:private analyse-jvm-invokestatic [analyse exo-type class method classes ?values] - (|do [!class! (&/de-alias-class class) - :let [args ?values] - class-loader &/loader - [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader !class! method classes) - _ (ensure-catching exceptions) - :let [gtype-env (&/|table)] - [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret))))))) - -(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] - (|case gtype-vars - (&/$Nil) - (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) - gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] - (return (&/T [(make-gtype gtype gtype-vars*) - =args]))) - - (&/$Cons ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] - [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) - ==gret (&type/clean $var =gret) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (return (&/T [==gret ==args]))))) - )) - -(defn ^:private analyse-jvm-new [analyse exo-type class classes ?values] - (|do [!class! (&/de-alias-class class) - :let [args ?values] - class-loader &/loader - [exceptions gvars gargs] (&host/lookup-constructor class-loader !class! classes) - _ (ensure-catching exceptions) - [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes))))))) - -(defn ^:private analyse-jvm-try [analyse exo-type ?values] - (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values] - =body (with-catches (&/|list "java.lang.Exception") - (&&/analyse-1 analyse exo-type ?body)) - =catch (&&/analyse-1 analyse (&/$LambdaT (&/$HostT "java.lang.Exception" &/$Nil) exo-type) ?catch) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "try"]) (&/|list =body =catch) (&/|list))))))) - -(defn ^:private analyse-jvm-instanceof [analyse exo-type class ?values] - (|do [:let [(&/$Cons object (&/$Nil)) ?values] - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - :let [output-type &type/Bool] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class))))))) - -(defn ^:private analyse-jvm-load-class [analyse exo-type ?values] - (|do [:let [(&/$Cons [_ (&/$TextS _class-name)] (&/$Nil)) ?values] - ^ClassLoader class-loader &/loader - _ (try (do (.loadClass class-loader _class-name) - (return nil)) - (catch Exception e - (&/fail-with-loc (str "[Analyser Error] Unknown class: " _class-name)))) - :let [output-type (&/$HostT "java.lang.Class" (&/|list (&/$HostT _class-name (&/|list))))] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type))))))) - -(let [length-type &type/Nat - idx-type &type/Nat] - (defn ^:private analyse-array-new [analyse exo-type ?values] - (|do [:let [(&/$Cons length (&/$Nil)) ?values] - :let [gclass (&/$GenericClass "java.lang.Object" (&/|list)) - array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))] - gtype-env &/get-type-env - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) - - (defn ^:private analyse-array-get [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list))))))) - - (defn ^:private analyse-array-remove [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - :let [array-type (&&/expr-type* =array)] - [arr-class arr-params] (ensure-object array-type) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _cursor &/cursor - :let [=elem (&&/|meta inner-arr-type _cursor - (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))] - _ (&type/check exo-type array-type)] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) - -(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods] - (|do [module &/get-module-name - _ (compile-interface interface-decl supers =anns =methods) - :let [_ (println 'INTERFACE (str module "." (&/|first interface-decl)))] - _cursor &/cursor] - (return (&/|list (&&/|meta &/$UnitT _cursor - (&&/$tuple (&/|list))))))) - -(defn ^:private analyse-jvm-class [analyse compile-class class-decl super-class interfaces =inheritance-modifier =anns ?fields methods] - (&/with-closure - (|do [module &/get-module-name - :let [[?name ?params] class-decl - full-name (str (string/replace module "/" ".") "." ?name) - class-decl* (&/T [full-name ?params]) - all-supers (&/$Cons super-class interfaces)] - class-env (make-type-env ?params) - =fields (&/map% (partial analyse-field analyse class-env) ?fields) - _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) - =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) - _ (check-method-completion all-supers =methods) - _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None) - _ &/pop-dummy-name - :let [_ (println 'CLASS full-name)] - _cursor &/cursor] - (return (&/|list (&&/|meta &/$UnitT _cursor - (&&/$tuple (&/|list)))))))) - -(defn ^:private captured-source [env-entry] - (|case env-entry - [name [_ (&&/$captured _ _ source)]] - source)) - -(let [default- (&/$ConstructorMethodSyntax (&/T [&/$PublicPM - false - &/$Nil - &/$Nil - &/$Nil - &/$Nil - &/$Nil - (&/$TupleS &/$Nil)])) - captured-slot-class "java.lang.Object" - captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] - (defn ^:private analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] - (&/with-closure - (|do [module &/get-module-name - scope &/get-scope-name - :let [name (->> scope &/|reverse &/|tail &host/location) - class-decl (&/T [name &/$Nil]) - anon-class (str (string/replace module "/" ".") "." name) - anon-class-type (&/$HostT anon-class &/$Nil)] - =ctor-args (&/map% (fn [ctor-arg] - (|let [[arg-type arg-term] ctor-arg] - (|do [=arg-term (&&/analyse-1+ analyse arg-term)] - (return (&/T [arg-type =arg-term]))))) - ctor-args) - _ (->> methods - (&/$Cons default-) - (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) - :let [all-supers (&/$Cons super-class interfaces) - class-env &/$Nil] - =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) - _ (check-method-completion all-supers =methods) - =captured &&env/captured-vars - :let [=fields (&/|map (fn [^objects idx+capt] - (|let [[idx _] idx+capt] - (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx) - &/$PublicPM - &/$FinalSM - &/$Nil - captured-slot-type))) - (&/enumerate =captured))] - :let [sources (&/|map captured-source =captured)] - _ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)) - _ &/pop-dummy-name - _cursor &/cursor] - (return (&/|list (&&/|meta anon-class-type _cursor - (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class))) - ))) - )))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] - =mask (&&/analyse-1 analyse &type/Nat mask) - =input (&&/analyse-1 analyse &type/Nat input) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" ]) (&/|list =input =mask) (&/|list))))))) - - ^:private analyse-bit-and "and" - ^:private analyse-bit-or "or" - ^:private analyse-bit-xor "xor" - ) - -(defn ^:private analyse-bit-count [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Nil)) ?values] - =input (&&/analyse-1 analyse &type/Nat input) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] - =shift (&&/analyse-1 analyse &type/Nat shift) - =input (&&/analyse-1 analyse input) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" ]) (&/|list =input =shift) (&/|list))))))) - - ^:private analyse-bit-shift-left "shift-left" &type/Nat - ^:private analyse-bit-shift-right "shift-right" &type/Int - ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat - ) - -(defn ^:private analyse-lux-== [analyse exo-type ?values] - (&type/with-var - (fn [$var] - (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] - =left (&&/analyse-1 analyse $var left) - =right (&&/analyse-1 analyse $var right) - _ (&type/check exo-type &type/Bool) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse x) - =y (&&/analyse-1 analyse y) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) - - ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat - ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat - ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat - ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat - ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat - ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool - ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool - - ^:private analyse-frac-add ["frac" "+"] &type/Frac &type/Frac - ^:private analyse-frac-sub ["frac" "-"] &type/Frac &type/Frac - ^:private analyse-frac-mul ["frac" "*"] &type/Frac &type/Frac - ^:private analyse-frac-div ["frac" "/"] &type/Frac &type/Frac - ^:private analyse-frac-rem ["frac" "%"] &type/Frac &type/Frac - ^:private analyse-frac-eq ["frac" "="] &type/Frac &type/Bool - ^:private analyse-frac-lt ["frac" "<"] &type/Frac &type/Bool - ) - -(defn ^:private analyse-frac-scale [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse &type/Frac x) - =y (&&/analyse-1 analyse &type/Nat y) - _ (&type/check exo-type &type/Frac) - _cursor &/cursor] - (return (&/|list (&&/|meta &type/Frac _cursor - (&&/$proc (&/T ["frac" "scale"]) (&/|list =x =y) (&/|list))))))) - -(do-template [ ] - (do (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse x) - _ (&type/check exo-type &type/Text) - _cursor &/cursor] - (return (&/|list (&&/|meta &type/Text _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - - (let [decode-type (&/$AppT &type/Maybe )] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse &type/Text x) - _ (&type/check exo-type decode-type) - _cursor &/cursor] - (return (&/|list (&&/|meta decode-type _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) - - ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat - ^:private analyse-frac-encode ["frac" "encode"] ^:private analyse-frac-decode ["frac" "decode"] &type/Frac - ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Nil) ?values] - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list) (&/|list))))))) - - ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] - ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] - - ^:private analyse-frac-min-value &type/Frac ["frac" "min-value"] - ^:private analyse-frac-max-value &type/Frac ["frac" "max-value"] - ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse x) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - - ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] - ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] - ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] - ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] - - ^:private analyse-frac-to-real &type/Frac &type/Real ["frac" "to-real"] - ^:private analyse-real-to-frac &type/Real &type/Frac ["real" "to-frac"] - ) - -(defn analyse-host [analyse exo-type compilers category proc ?values] - (|let [[_ _ compile-class compile-interface] compilers] - (case category - "lux" - (case proc - "==" (analyse-lux-== analyse exo-type ?values)) - - "bit" - (case proc - "count" (analyse-bit-count analyse exo-type ?values) - "and" (analyse-bit-and analyse exo-type ?values) - "or" (analyse-bit-or analyse exo-type ?values) - "xor" (analyse-bit-xor analyse exo-type ?values) - "shift-left" (analyse-bit-shift-left analyse exo-type ?values) - "shift-right" (analyse-bit-shift-right analyse exo-type ?values) - "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) - - "array" - (case proc - "new" (analyse-array-new analyse exo-type ?values) - "get" (analyse-array-get analyse exo-type ?values) - "put" (analyse-jvm-aastore analyse exo-type ?values) - "remove" (analyse-array-remove analyse exo-type ?values) - "size" (analyse-jvm-arraylength analyse exo-type ?values)) - - "nat" - (case proc - "+" (analyse-nat-add analyse exo-type ?values) - "-" (analyse-nat-sub analyse exo-type ?values) - "*" (analyse-nat-mul analyse exo-type ?values) - "/" (analyse-nat-div analyse exo-type ?values) - "%" (analyse-nat-rem analyse exo-type ?values) - "=" (analyse-nat-eq analyse exo-type ?values) - "<" (analyse-nat-lt analyse exo-type ?values) - "encode" (analyse-nat-encode analyse exo-type ?values) - "decode" (analyse-nat-decode analyse exo-type ?values) - "min-value" (analyse-nat-min-value analyse exo-type ?values) - "max-value" (analyse-nat-max-value analyse exo-type ?values) - "to-int" (analyse-nat-to-int analyse exo-type ?values) - "to-char" (analyse-nat-to-char analyse exo-type ?values) - ) - - "frac" - (case proc - "+" (analyse-frac-add analyse exo-type ?values) - "-" (analyse-frac-sub analyse exo-type ?values) - "*" (analyse-frac-mul analyse exo-type ?values) - "/" (analyse-frac-div analyse exo-type ?values) - "%" (analyse-frac-rem analyse exo-type ?values) - "=" (analyse-frac-eq analyse exo-type ?values) - "<" (analyse-frac-lt analyse exo-type ?values) - "encode" (analyse-frac-encode analyse exo-type ?values) - "decode" (analyse-frac-decode analyse exo-type ?values) - "min-value" (analyse-frac-min-value analyse exo-type ?values) - "max-value" (analyse-frac-max-value analyse exo-type ?values) - "to-real" (analyse-frac-to-real analyse exo-type ?values) - "scale" (analyse-frac-scale analyse exo-type ?values) - ) - - "int" - (case proc - "to-nat" (analyse-int-to-nat analyse exo-type ?values) - ) - - "real" - (case proc - "to-frac" (analyse-real-to-frac analyse exo-type ?values) - ) - - "char" - (case proc - "to-nat" (analyse-char-to-nat analyse exo-type ?values) - ) - - "jvm" - (case proc - "synchronized" (analyse-jvm-synchronized analyse exo-type ?values) - "load-class" (analyse-jvm-load-class analyse exo-type ?values) - "try" (analyse-jvm-try analyse exo-type ?values) - "throw" (analyse-jvm-throw analyse exo-type ?values) - "monitorenter" (analyse-jvm-monitorenter analyse exo-type ?values) - "monitorexit" (analyse-jvm-monitorexit analyse exo-type ?values) - "null?" (analyse-jvm-null? analyse exo-type ?values) - "null" (analyse-jvm-null analyse exo-type ?values) - "anewarray" (analyse-jvm-anewarray analyse exo-type ?values) - "aaload" (analyse-jvm-aaload analyse exo-type ?values) - "aastore" (analyse-jvm-aastore analyse exo-type ?values) - "arraylength" (analyse-jvm-arraylength analyse exo-type ?values) - "znewarray" (analyse-jvm-znewarray analyse exo-type ?values) - "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) - "snewarray" (analyse-jvm-snewarray analyse exo-type ?values) - "inewarray" (analyse-jvm-inewarray analyse exo-type ?values) - "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) - "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) - "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) - "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) - "iadd" (analyse-jvm-iadd analyse exo-type ?values) - "isub" (analyse-jvm-isub analyse exo-type ?values) - "imul" (analyse-jvm-imul analyse exo-type ?values) - "idiv" (analyse-jvm-idiv analyse exo-type ?values) - "irem" (analyse-jvm-irem analyse exo-type ?values) - "ieq" (analyse-jvm-ieq analyse exo-type ?values) - "ilt" (analyse-jvm-ilt analyse exo-type ?values) - "igt" (analyse-jvm-igt analyse exo-type ?values) - "ceq" (analyse-jvm-ceq analyse exo-type ?values) - "clt" (analyse-jvm-clt analyse exo-type ?values) - "cgt" (analyse-jvm-cgt analyse exo-type ?values) - "ladd" (analyse-jvm-ladd analyse exo-type ?values) - "lsub" (analyse-jvm-lsub analyse exo-type ?values) - "lmul" (analyse-jvm-lmul analyse exo-type ?values) - "ldiv" (analyse-jvm-ldiv analyse exo-type ?values) - "lrem" (analyse-jvm-lrem analyse exo-type ?values) - "leq" (analyse-jvm-leq analyse exo-type ?values) - "llt" (analyse-jvm-llt analyse exo-type ?values) - "lgt" (analyse-jvm-lgt analyse exo-type ?values) - "fadd" (analyse-jvm-fadd analyse exo-type ?values) - "fsub" (analyse-jvm-fsub analyse exo-type ?values) - "fmul" (analyse-jvm-fmul analyse exo-type ?values) - "fdiv" (analyse-jvm-fdiv analyse exo-type ?values) - "frem" (analyse-jvm-frem analyse exo-type ?values) - "feq" (analyse-jvm-feq analyse exo-type ?values) - "flt" (analyse-jvm-flt analyse exo-type ?values) - "fgt" (analyse-jvm-fgt analyse exo-type ?values) - "dadd" (analyse-jvm-dadd analyse exo-type ?values) - "dsub" (analyse-jvm-dsub analyse exo-type ?values) - "dmul" (analyse-jvm-dmul analyse exo-type ?values) - "ddiv" (analyse-jvm-ddiv analyse exo-type ?values) - "drem" (analyse-jvm-drem analyse exo-type ?values) - "deq" (analyse-jvm-deq analyse exo-type ?values) - "dlt" (analyse-jvm-dlt analyse exo-type ?values) - "dgt" (analyse-jvm-dgt analyse exo-type ?values) - "iand" (analyse-jvm-iand analyse exo-type ?values) - "ior" (analyse-jvm-ior analyse exo-type ?values) - "ixor" (analyse-jvm-ixor analyse exo-type ?values) - "ishl" (analyse-jvm-ishl analyse exo-type ?values) - "ishr" (analyse-jvm-ishr analyse exo-type ?values) - "iushr" (analyse-jvm-iushr analyse exo-type ?values) - "land" (analyse-jvm-land analyse exo-type ?values) - "lor" (analyse-jvm-lor analyse exo-type ?values) - "lxor" (analyse-jvm-lxor analyse exo-type ?values) - "lshl" (analyse-jvm-lshl analyse exo-type ?values) - "lshr" (analyse-jvm-lshr analyse exo-type ?values) - "lushr" (analyse-jvm-lushr analyse exo-type ?values) - "d2f" (analyse-jvm-d2f analyse exo-type ?values) - "d2i" (analyse-jvm-d2i analyse exo-type ?values) - "d2l" (analyse-jvm-d2l analyse exo-type ?values) - "f2d" (analyse-jvm-f2d analyse exo-type ?values) - "f2i" (analyse-jvm-f2i analyse exo-type ?values) - "f2l" (analyse-jvm-f2l analyse exo-type ?values) - "i2b" (analyse-jvm-i2b analyse exo-type ?values) - "i2c" (analyse-jvm-i2c analyse exo-type ?values) - "i2d" (analyse-jvm-i2d analyse exo-type ?values) - "i2f" (analyse-jvm-i2f analyse exo-type ?values) - "i2l" (analyse-jvm-i2l analyse exo-type ?values) - "i2s" (analyse-jvm-i2s analyse exo-type ?values) - "l2d" (analyse-jvm-l2d analyse exo-type ?values) - "l2f" (analyse-jvm-l2f analyse exo-type ?values) - "l2i" (analyse-jvm-l2i analyse exo-type ?values) - "l2s" (analyse-jvm-l2s analyse exo-type ?values) - "l2b" (analyse-jvm-l2b analyse exo-type ?values) - "c2b" (analyse-jvm-c2b analyse exo-type ?values) - "c2s" (analyse-jvm-c2s analyse exo-type ?values) - "c2i" (analyse-jvm-c2i analyse exo-type ?values) - "c2l" (analyse-jvm-c2l analyse exo-type ?values) - "b2l" (analyse-jvm-b2l analyse exo-type ?values) - "s2l" (analyse-jvm-s2l analyse exo-type ?values) - ;; else - (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])) - (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)] - (&reader/with-source "interface" _def-code - (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] - (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods)))) - - (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)] - (&reader/with-source "class" _def-code - (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] - (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods)))) - - (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)] - (&reader/with-source "anon-class" _def-code - (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] - (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods)))) - - (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)] - (analyse-jvm-instanceof analyse exo-type _class ?values)) - - (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] - (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getfield analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putfield analyse exo-type _class _field ?values)))) - - ;; else - (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj deleted file mode 100644 index b47b803d0..000000000 --- a/src/lux/analyser/lambda.clj +++ /dev/null @@ -1,33 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.analyser.lambda - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case]] - [host :as &host]) - (lux.analyser [base :as &&] - [env :as &env]))) - -;; [Resource] -(defn with-lambda [self self-type arg arg-type body] - (&/with-closure - (|do [scope-name &/get-scope-name] - (&env/with-local self self-type - (&env/with-local arg arg-type - (|do [=return body - =captured &env/captured-vars] - (return (&/T [scope-name =captured =return])))))))) - -(defn close-over [scope name register frame] - (|let [[[register-type register-cursor] _] register - register* (&&/|meta register-type register-cursor - (&&/$captured (&/T [scope - (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) - register])))] - (&/T [register* (&/update$ &/$closure #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) - frame)]))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj deleted file mode 100644 index 1d46c2b60..000000000 --- a/src/lux/analyser/lux.clj +++ /dev/null @@ -1,736 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.analyser.lux - (:require (clojure [template :refer [do-template]] - [set :as set]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail* |let |list |case]] - [parser :as &parser] - [type :as &type] - [host :as &host]) - (lux.analyser [base :as &&] - [lambda :as &&lambda] - [case :as &&case] - [env :as &&env] - [module :as &&module] - [record :as &&record] - [meta :as &&meta]))) - -;; [Utils] -;; TODO: Walk the type to set up the bound-type, instead of doing a -;; rough calculation like this one. -(defn ^:private count-univq [type] - "(-> Type Int)" - (|case type - (&/$UnivQ env type*) - (inc (count-univq type*)) - - _ - 0)) - -;; TODO: This technique won't work if the body of the type contains -;; nested quantifications that cannot be directly counted. -(defn ^:private next-bound-type [type] - "(-> Type Type)" - (&/$BoundT (->> (count-univq type) (* 2) (+ 1)))) - -(defn ^:private embed-inferred-input [input output] - "(-> Type Type Type)" - (|case output - (&/$UnivQ env output*) - (&/$UnivQ env (embed-inferred-input input output*)) - - _ - (&/$LambdaT input output))) - -;; [Exports] -(defn analyse-unit [analyse ?exo-type] - (|do [_cursor &/cursor - _ (&type/check ?exo-type &/$UnitT)] - (return (&/|list (&&/|meta ?exo-type _cursor - (&&/$tuple (&/|list))))))) - -(defn analyse-tuple [analyse ?exo-type ?elems] - (|case ?elems - (&/$Nil) - (analyse-unit analyse (|case ?exo-type - (&/$Left exo-type) exo-type - (&/$Right exo-type) exo-type)) - - (&/$Cons ?elem (&/$Nil)) - (analyse (|case ?exo-type - (&/$Left exo-type) exo-type - (&/$Right exo-type) exo-type) - ?elem) - - _ - (|case ?exo-type - (&/$Left exo-type) - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var) - [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left exo-type**) ?elems)) - =var (&type/resolve-type $var) - inferred-type (|case =var - (&/$VarT iid) - (|do [:let [=var* (next-bound-type tuple-type)] - _ (&type/set-var iid =var*) - tuple-type* (&type/clean $var tuple-type)] - (return (&/$UnivQ &/$Nil tuple-type*))) - - _ - (&type/clean $var tuple-type))] - (return (&/|list (&&/|meta inferred-type tuple-cursor - tuple-analysis)))))) - - _ - (analyse-tuple analyse (&/$Right exo-type*) ?elems))) - - (&/$Right exo-type) - (|do [unknown? (&type/unknown? exo-type)] - (if unknown? - (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] - (return =analysis)) - ?elems) - _ (&type/check exo-type (|case (->> (&/|map &&/expr-type* =elems) (&/|reverse)) - (&/$Cons last prevs) - (&/fold (fn [right left] (&/$ProdT left right)) - last prevs))) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$tuple =elems) - )))) - (|do [exo-type* (&type/actual-type exo-type)] - (&/with-attempt - (|case exo-type* - (&/$ProdT _) - (|let [num-elems (&/|length ?elems) - [_shorter _tuple-types] (&type/tuple-types-for num-elems exo-type*)] - (if (= num-elems _shorter) - (|do [=elems (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - _tuple-types - ?elems) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$tuple =elems) - )))) - (|do [=direct-elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) - (&/|take (dec _shorter) _tuple-types) - (&/|take (dec _shorter) ?elems)) - =indirect-elems (analyse-tuple analyse - (&/$Right (&/|last _tuple-types)) - (&/|drop (dec _shorter) ?elems)) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$tuple (&/|++ =direct-elems =indirect-elems)) - )))))) - - (&/$ExQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var) - [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)) - =tuple-analysis (&&/clean-analysis $var (&&/|meta exo-type tuple-cursor - tuple-analysis))] - (return (&/|list =tuple-analysis))))) - - (&/$UnivQ _) - (|do [$var &type/existential - :let [(&/$ExT $var-id) $var] - exo-type** (&type/apply-type exo-type* $var) - [[tuple-type tuple-cursor] tuple-analysis] (&/with-scope-type-var $var-id - (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)))] - (return (&/|list (&&/|meta exo-type tuple-cursor - tuple-analysis)))) - - _ - (&/fail-with-loc (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))) - ) - (fn [err] - (&/fail-with-loc (str err "\n" "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type))))))))) - )) - -(defn ^:private analyse-variant-body [analyse exo-type ?values] - (|do [_cursor &/cursor - output (|case ?values - (&/$Nil) - (analyse-unit analyse exo-type) - - (&/$Cons ?value (&/$Nil)) - (analyse exo-type ?value) - - _ - (analyse-tuple analyse (&/$Right exo-type) ?values))] - (|case output - (&/$Cons x (&/$Nil)) - (return x) - - _ - (&/fail-with-loc "[Analyser Error] Can't expand to other than 1 element.")))) - -(defn analyse-variant [analyse ?exo-type idx is-last? ?values] - (|case ?exo-type - (&/$Left exo-type) - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var) - [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/$Left exo-type**) idx is-last? ?values)) - =var (&type/resolve-type $var) - inferred-type (|case =var - (&/$VarT iid) - (|do [:let [=var* (next-bound-type variant-type)] - _ (&type/set-var iid =var*) - variant-type* (&type/clean $var variant-type)] - (return (&/$UnivQ &/$Nil variant-type*))) - - _ - (&type/clean $var variant-type))] - (return (&/|list (&&/|meta inferred-type variant-cursor - variant-analysis)))))) - - _ - (analyse-variant analyse (&/$Right exo-type*) idx is-last? ?values))) - - (&/$Right exo-type) - (|do [exo-type* (|case exo-type - (&/$VarT ?id) - (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] - (&type/actual-type exo-type*)) - (|do [_ (&type/set-var ?id &type/Type)] - (&type/actual-type &type/Type)))) - - _ - (&type/actual-type exo-type))] - (&/with-attempt - (|case exo-type* - (&/$SumT _) - (|do [vtype (&type/sum-at idx exo-type*) - :let [num-variant-types (&/|length (&type/flatten-sum exo-type*)) - is-last?* (if (nil? is-last?) - (= idx (dec num-variant-types)) - is-last?)] - =value (analyse-variant-body analyse vtype ?values) - _cursor &/cursor] - (if (= 1 num-variant-types) - (return (&/|list =value)) - (return (&/|list (&&/|meta exo-type _cursor (&&/$variant idx is-last?* =value)))) - )) - - (&/$UnivQ _) - (|do [$var &type/existential - exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)) - - (&/$ExQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var) - =exprs (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)] - (&/map% (partial &&/clean-analysis $var) =exprs)))) - - _ - (&/fail-with-loc (str "[Analyser Error] Can't create variant if the expected type is " (&type/show-type exo-type*) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) - (fn [err] - (|case exo-type - (&/$VarT ?id) - (|do [=exo-type (&type/deref ?id)] - (&/fail-with-loc (str err "\n" "[Analyser Error] Can't create variant if the expected type is " (&type/show-type =exo-type) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) - - _ - (&/fail-with-loc (str err "\n" "[Analyser Error] Can't create variant if the expected type is " (&type/show-type exo-type) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) - ))) - -(defn analyse-record [analyse exo-type ?elems] - (|do [[rec-members rec-type] (&&record/order-record ?elems)] - (|case exo-type - (&/$VarT id) - (|do [? (&type/bound? id)] - (if ? - (analyse-tuple analyse (&/$Right exo-type) rec-members) - (|do [[[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left rec-type) rec-members)) - _ (&type/check exo-type tuple-type)] - (return (&/|list (&&/|meta exo-type tuple-cursor - tuple-analysis)))))) - - _ - (analyse-tuple analyse (&/$Right exo-type) rec-members) - ))) - -(defn ^:private analyse-global [analyse exo-type module name] - (|do [[[r-module r-name] [endo-type ?meta ?value]] (&&module/find-def module name) - ;; This is a small shortcut to optimize analysis of typing code. - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta endo-type _cursor - (&&/$var (&/$Global (&/T [r-module r-name])))))))) - -(defn ^:private analyse-local [analyse exo-type name] - (fn [state] - (|let [stack (&/get$ &/$scopes state) - no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) - (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) - [inner outer] (&/|split-with no-binding? stack)] - (|case outer - (&/$Nil) - (&/run-state (|do [module-name &/get-module-name] - (analyse-global analyse exo-type module-name name)) - state) - - (&/$Cons ?genv (&/$Nil)) - (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] - (|case global - [(&/$Global ?module* name*) _] - (&/run-state (analyse-global analyse exo-type ?module* name*) - state) - - _ - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")) - (fail* (str "[Analyser Error] Unknown global definition: " name))) - - (&/$Cons bottom-outer _) - (|let [scopes (&/|map #(&/get$ &/$name %) (&/|reverse inner)) - [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] - (|let [[register new-inner] register+new-inner - [register* frame*] (&&lambda/close-over in-scope name register frame)] - (&/T [register* (&/$Cons frame* new-inner)]))) - (&/T [(or (->> bottom-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) - (->> bottom-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) - &/$Nil]) - (&/|reverse inner) scopes)] - ((|do [_ (&type/check exo-type (&&/expr-type* =local))] - (return (&/|list =local))) - (&/set$ &/$scopes (&/|++ inner* outer) state))) - )))) - -(defn analyse-symbol [analyse exo-type ident] - (|do [:let [[?module ?name] ident]] - (if (= "" ?module) - (analyse-local analyse exo-type ?name) - (analyse-global analyse exo-type ?module ?name)) - )) - -(defn ^:private analyse-apply* [analyse exo-type fun-type ?args] - (|case ?args - (&/$Nil) - (|do [_ (&type/check exo-type fun-type)] - (return (&/T [fun-type &/$Nil]))) - - (&/$Cons ?arg ?args*) - (|do [?fun-type* (&type/actual-type fun-type)] - (&/with-attempt - (|case ?fun-type* - (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [type* (&type/apply-type ?fun-type* $var) - [=output-t =args] (analyse-apply* analyse exo-type type* ?args) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (|case $var - (&/$VarT ?id) - (|do [? (&type/bound? ?id) - type** (if ? - (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (next-bound-type =output-t)) - cleaned-output* (&type/clean $var =output-t) - :let [cleaned-output (&/$UnivQ &/$Nil cleaned-output*)]] - (return cleaned-output))) - _ (&type/clean $var exo-type)] - (return (&/T [type** ==args]))) - )))) - - (&/$ExQ _) - (|do [$var &type/existential - type* (&type/apply-type ?fun-type* $var)] - (analyse-apply* analyse exo-type type* ?args)) - - (&/$LambdaT ?input-t ?output-t) - (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) - =arg (&/with-attempt - (&&/analyse-1 analyse ?input-t ?arg) - (fn [err] - (&/fail-with-loc (str err "\n" "[Analyser Error] Function expected: " (&type/show-type ?input-t)))))] - (return (&/T [=output-t (&/$Cons =arg =args)]))) - - _ - (&/fail-with-loc (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*)))) - (fn [err] - (&/fail-with-loc (str err "\n" "[Analyser Error] Can't apply function " (&type/show-type fun-type) " to args: " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) - )) - -(defn ^:private do-analyse-apply [analyse exo-type =fn ?args] - (|do [:let [[[=fn-type =fn-cursor] =fn-form] =fn] - [=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&&/|meta =output-t =fn-cursor - (&&/$apply =fn =args) - ))))) - -(defn analyse-apply [analyse cursor exo-type =fn ?args] - (|do [loader &/loader - :let [[[=fn-type =fn-cursor] =fn-form] =fn]] - (|case =fn-form - (&&/$var (&/$Global ?module ?name)) - (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)] - (|case (&&meta/meta-get &&meta/macro?-tag ?meta) - (&/$Some _) - (|do [macro-expansion (fn [state] - (|case (-> ?value (.apply ?args) (.apply state)) - (&/$Right state* output) - (&/$Right (&/T [state* output])) - - (&/$Left error) - ((&/fail-with-loc error) state))) - module-name &/get-module-name - ;; :let [[r-prefix r-name] real-name - ;; _ (when (or (= "actor:" r-name) - ;; ;; (= "|Codec@Json|" r-name) - ;; ;; (= "|Codec@Json//encode|" r-name) - ;; ;; (= "|Codec@Json//decode|" r-name) - ;; ;; (= "derived:" r-name) - ;; ) - ;; (->> (&/|map &/show-ast macro-expansion) - ;; (&/|interpose "\n") - ;; (&/fold str "") - ;; (prn (&/ident->text real-name) module-name))) - ;; ] - ] - (&/flat-map% (partial analyse exo-type) macro-expansion)) - - _ - (do-analyse-apply analyse exo-type =fn ?args))) - - _ - (do-analyse-apply analyse exo-type =fn ?args)) - )) - -(defn analyse-case [analyse exo-type ?value ?branches] - (|do [:let [num-branches (&/|length ?branches)] - _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case\" expression.") - _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case\" expression.") - =value (&&/analyse-1+ analyse ?value) - :let [var?? (|case =value - [_ (&&/$var =var-kind)] - (&/$Some =value) - - _ - &/$None)] - =match (&&case/analyse-branches analyse exo-type var?? (&&/expr-type* =value) (&/|as-pairs ?branches)) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$case =value =match) - ))))) - -(defn ^:private unravel-inf-appt [type] - (|case type - (&/$AppT =input+ (&/$VarT _inf-var)) - (&/$Cons _inf-var (unravel-inf-appt =input+)) - - _ - (&/|list))) - -(defn ^:private clean-func-inference [$input $output =input =func] - (|case =input - (&/$VarT iid) - (|do [:let [=input* (next-bound-type =func)] - _ (&type/set-var iid =input*) - =func* (&type/clean $input =func) - =func** (&type/clean $output =func*)] - (return (&/$UnivQ &/$Nil =func**))) - - (&/$AppT =input+ (&/$VarT _inf-var)) - (&/fold% (fn [_func _inf-var] - (|do [:let [$inf-var (&/$VarT _inf-var)] - =inf-var (&type/resolve-type $inf-var) - _func* (clean-func-inference $inf-var $output =inf-var _func) - _ (&type/delete-var _inf-var)] - (return _func*))) - =func - (unravel-inf-appt =input)) - - (&/$ProdT _ _) - (&/fold% (fn [_func _inf-var] - (|do [:let [$inf-var (&/$VarT _inf-var)] - =inf-var (&type/resolve-type $inf-var) - _func* (clean-func-inference $inf-var $output =inf-var _func) - _ (&type/delete-var _inf-var)] - (return _func*))) - =func - (&/|reverse (&type/flatten-prod =input))) - - _ - (|do [=func* (&type/clean $input =func) - =func** (&type/clean $output =func*)] - (return =func**)))) - -(defn analyse-lambda* [analyse exo-type ?self ?arg ?body] - (|case exo-type - (&/$VarT id) - (|do [? (&type/bound? id)] - (if ? - (|do [exo-type* (&type/deref id)] - (analyse-lambda* analyse exo-type* ?self ?arg ?body)) - ;; Inference - (&type/with-var - (fn [$input] - (&type/with-var - (fn [$output] - (|do [[[lambda-type lambda-cursor] lambda-analysis] (analyse-lambda* analyse (&/$LambdaT $input $output) ?self ?arg ?body) - =input (&type/resolve-type $input) - =output (&type/resolve-type $output) - inferred-type (clean-func-inference $input $output =input (embed-inferred-input =input =output)) - _ (&type/check exo-type inferred-type)] - (return (&&/|meta inferred-type lambda-cursor - lambda-analysis))) - )))))) - - _ - (&/with-attempt - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$UnivQ _) - (|do [$var &type/existential - :let [(&/$ExT $var-id) $var] - exo-type** (&type/apply-type exo-type* $var)] - (&/with-scope-type-var $var-id - (analyse-lambda* analyse exo-type** ?self ?arg ?body))) - - (&/$ExQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var) - =expr (analyse-lambda* analyse exo-type** ?self ?arg ?body)] - (&&/clean-analysis $var =expr)))) - - (&/$LambdaT ?arg-t ?return-t) - (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* - ?arg ?arg-t - (&&/analyse-1 analyse ?return-t ?body)) - _cursor &/cursor - register-offset &&env/next-local-idx] - (return (&&/|meta exo-type* _cursor - (&&/$lambda register-offset =scope =captured =body)))) - - _ - (fail ""))) - (fn [err] - (&/fail-with-loc (str err "\n" "[Analyser Error] Functions require function types: " (&type/show-type exo-type))))) - )) - -(defn analyse-lambda** [analyse exo-type ?self ?arg ?body] - (|case exo-type - (&/$UnivQ _) - (|do [$var &type/existential - :let [(&/$ExT $var-id) $var] - exo-type* (&type/apply-type exo-type $var) - [_ _expr] (&/with-scope-type-var $var-id - (analyse-lambda** analyse exo-type* ?self ?arg ?body)) - _cursor &/cursor] - (return (&&/|meta exo-type _cursor _expr))) - - (&/$VarT id) - (|do [? (&type/bound? id)] - (if ? - (|do [exo-type* (&type/actual-type exo-type)] - (analyse-lambda* analyse exo-type* ?self ?arg ?body)) - ;; Inference - (analyse-lambda* analyse exo-type ?self ?arg ?body))) - - _ - (|do [exo-type* (&type/actual-type exo-type)] - (analyse-lambda* analyse exo-type* ?self ?arg ?body)) - )) - -(defn analyse-lambda [analyse exo-type ?self ?arg ?body] - (|do [output (&/with-no-catches - (analyse-lambda** analyse exo-type ?self ?arg ?body))] - (return (&/|list output)))) - -(defn analyse-def [analyse optimize eval! compile-def ?name ?value ?meta] - (|do [_ &/ensure-statement - module-name &/get-module-name - ? (&&module/defined? module-name ?name)] - (if ? - (&/fail-with-loc (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) - (|do [=value (&/without-repl-closure - (&/with-scope ?name - (&&/analyse-1+ analyse ?value))) - =meta (&&/analyse-1 analyse &type/Anns ?meta) - ==meta (eval! (optimize =meta)) - _ (&&module/test-type module-name ?name ==meta (&&/expr-type* =value)) - _ (&&module/test-macro module-name ?name ==meta (&&/expr-type* =value)) - _ (compile-def ?name (optimize =value) ==meta)] - (return &/$Nil)) - ))) - -(defn ^:private merge-hosts - "(-> Host Host Host)" - [new old] - (|let [merged-module-states (&/fold (fn [total m-state] - (|let [[_name _state] m-state] - (|case _state - (&/$Cached) - (&/|put _name _state total) - - (&/$Compiled) - (&/|put _name _state total) - - _ - total))) - (&/get$ &/$module-states old) - (&/get$ &/$module-states new))] - (->> old - (&/set$ &/$module-states merged-module-states)))) - -(defn ^:private merge-modules - "(-> Text Module Module Module)" - [current-module new old] - (&/fold (fn [total* entry] - (|let [[_name _module] entry] - (if (or (= current-module _name) - (->> _module - (&/get$ &&module/$defs) - &/|length - (= 0))) - ;; Don't modify the entry of the current module, to - ;; avoid overwritting it's data in improper ways. - ;; Since it's assumed the "original" old module - ;; contains all the proper own-module information. - total* - (&/|put _name _module total*)))) - old new)) - -(defn ^:private merge-compilers - "(-> Text Compiler Compiler Compiler)" - [current-module new old] - (->> old - (&/set$ &/$modules (merge-modules current-module - (&/get$ &/$modules new) - (&/get$ &/$modules old))) - (&/set$ &/$seed (max (&/get$ &/$seed new) - (&/get$ &/$seed old))) - (&/set$ &/$host (merge-hosts (&/get$ &/$host new) - (&/get$ &/$host old))))) - -(def ^:private get-compiler - (fn [compiler] - (return* compiler compiler))) - -(defn ^:private set-compiler [compiler*] - (fn [_] - (return* compiler* compiler*))) - -(defn analyse-module [analyse optimize eval! compile-module ?meta] - (|do [_ &/ensure-statement - =anns (&&/analyse-1 analyse &type/Anns ?meta) - ==anns (eval! (optimize =anns)) - module-name &/get-module-name - _ (&&module/set-anns ==anns module-name) - _imports (&&module/fetch-imports ==anns) - current-module &/get-module-name - ;; =asyncs (&/map% (fn [_import] - ;; (|let [[path alias] _import] - ;; (&/without-repl - ;; (&/save-module - ;; (|do [_ (if (= current-module path) - ;; (&/fail-with-loc (str "[Analyser Error] Module can't import itself: " path)) - ;; (return nil)) - ;; already-compiled? (&&module/exists? path) - ;; active? (&/active-module? path) - ;; _ (&/assert! (not active?) - ;; (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " current-module)) - ;; _ (&&module/add-import path) - ;; ?async (if (not already-compiled?) - ;; (compile-module path) - ;; (|do [_compiler get-compiler] - ;; (return (doto (promise) - ;; (deliver (&/$Right _compiler)))))) - ;; _ (if (= "" alias) - ;; (return nil) - ;; (&&module/alias current-module alias path))] - ;; (return ?async)))))) - ;; _imports) - ;; _compiler get-compiler - ;; ;; Some type-vars in the typing environment stay in - ;; ;; the environment forever, making type-checking slower. - ;; ;; The merging process for compilers more-or-less "fixes" the - ;; ;; problem by resetting the typing enviroment, but ideally - ;; ;; those type-vars shouldn't survive in the first place. - ;; ;; TODO: MUST FIX - ;; _ (&/fold% (fn [compiler _async] - ;; (|case @_async - ;; (&/$Right _new-compiler) - ;; (set-compiler (merge-compilers current-module _new-compiler compiler)) - - ;; (&/$Left ?error) - ;; (fail ?error))) - ;; _compiler - ;; =asyncs) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - _ (&/map% (fn [_import] - (|let [[path alias] _import] - (&/without-repl - (&/save-module - (|do [_ (if (= current-module path) - (&/fail-with-loc (str "[Analyser Error] Module can't import itself: " path)) - (return nil)) - already-compiled? (&&module/exists? path) - active? (&/active-module? path) - _ (&/assert! (not active?) - (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " current-module)) - _ (&&module/add-import path) - _ (if (not already-compiled?) - (compile-module path) - (return nil)) - _ (if (= "" alias) - (return nil) - (&&module/alias current-module alias path))] - (return nil)))))) - _imports)] - (return &/$Nil))) - -(defn ^:private coerce [new-type analysis] - "(-> Type Analysis Analysis)" - (|let [[[_type _cursor] _analysis] analysis] - (&&/|meta new-type _cursor - _analysis))) - -(defn analyse-ann [analyse eval! exo-type ?type ?value] - (|do [=type (&&/analyse-1 analyse &type/Type ?type) - ==type (eval! =type) - _ (&type/check exo-type ==type) - =value (&/with-expected-type ==type - (&&/analyse-1 analyse ==type ?value)) - _cursor &/cursor] - (return (&/|list (&&/|meta ==type _cursor - (&&/$ann =value =type) - ))))) - -(defn analyse-coerce [analyse eval! exo-type ?type ?value] - (|do [=type (&&/analyse-1 analyse &type/Type ?type) - ==type (eval! =type) - _ (&type/check exo-type ==type) - =value (&&/analyse-1+ analyse ?value)] - (return (&/|list (coerce ==type =value))))) - -(let [input-type (&/$AppT &type/List &type/Text) - output-type (&/$AppT &type/IO &/$UnitT)] - (defn analyse-program [analyse optimize compile-program ?args ?body] - (|do [_ &/ensure-statement - =body (&/with-scope "" - (&&env/with-local ?args input-type - (&&/analyse-1 analyse output-type ?body))) - _ (compile-program (optimize =body))] - (return &/$Nil)))) diff --git a/src/lux/analyser/meta.clj b/src/lux/analyser/meta.clj deleted file mode 100644 index 831386f47..000000000 --- a/src/lux/analyser/meta.clj +++ /dev/null @@ -1,46 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.analyser.meta - (:require (clojure [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return return* fail fail* |case]]))) - -;; [Utils] -(defn ^:private ident= [x y] - (|let [[px nx] x - [py ny] y] - (and (= px py) - (= nx ny)))) - -(def ^:private tag-prefix "lux") - -;; [Values] -(defn meta-get [ident dict] - "(-> Ident Anns (Maybe Ann-Value))" - (|case dict - (&/$Cons [k v] dict*) - (if (ident= k ident) - (&/$Some v) - (meta-get ident dict*)) - - (&/$Nil) - &/$None - - _ - (assert false (prn-str (&/adt->text ident) - (&/adt->text dict))))) - -(do-template [ ] - (def (&/T [tag-prefix ])) - - type?-tag "type?" - alias-tag "alias" - macro?-tag "macro?" - export?-tag "export?" - tags-tag "tags" - imports-tag "imports" - ) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj deleted file mode 100644 index 62948bf0d..000000000 --- a/src/lux/analyser/module.clj +++ /dev/null @@ -1,403 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.analyser.module - (:refer-clojure :exclude [alias]) - (:require (clojure [string :as string] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [deftuple |let |do return return* |case]] - [type :as &type] - [host :as &host]) - [lux.host.generics :as &host-generics] - (lux.analyser [meta :as &meta]))) - -;; [Utils] -(deftuple - ["module-hash" - "module-aliases" - "defs" - "imports" - "tags" - "types" - "module-anns"]) - -(defn ^:private new-module [hash] - (&/T [;; lux;module-hash - hash - ;; "lux;module-aliases" - (&/|table) - ;; "lux;defs" - (&/|table) - ;; "lux;imports" - &/$Nil - ;; "lux;tags" - (&/|table) - ;; "lux;types" - (&/|table) - ;; module-anns - (&/|list)] - )) - -;; [Exports] -(defn add-import - "(-> Text (Lux Null))" - [module] - (|do [current-module &/get-module-name] - (fn [state] - (if (&/|member? module (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $imports))) - ((&/fail-with-loc (str "[Analyser Error] Can't import module " (pr-str module) " twice @ " current-module)) - state) - (return* (&/update$ &/$modules - (fn [ms] - (&/|update current-module - (fn [m] (&/update$ $imports (partial &/$Cons module) m)) - ms)) - state) - nil))))) - -(defn set-imports - "(-> (List Text) (Lux Null))" - [imports] - (|do [current-module &/get-module-name] - (fn [state] - (return* (&/update$ &/$modules - (fn [ms] - (&/|update current-module - (fn [m] (&/set$ $imports imports m)) - ms)) - state) - nil)))) - -(defn define [module name def-type def-meta def-value] - (fn [state] - (when (and (= "Macro" name) (= "lux" module)) - (&type/set-macro-type! def-value)) - (|case (&/get$ &/$scopes state) - (&/$Cons ?env (&/$Nil)) - (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - (fn [m] - (&/update$ $defs - #(&/|put name (&/T [def-type def-meta def-value]) %) - m)) - ms)))) - nil) - - _ - ((&/fail-with-loc (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name)) - state)))) - -(defn def-type - "(-> Text Text (Lux Type))" - [module name] - (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|let [[?type ?meta ?value] $def] - (return* state ?type)) - ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (str module ";" name))) - state)) - ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module)) - state)))) - -(defn type-def - "(-> Text Text (Lux [Bool Type]))" - [module name] - (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|let [[?type ?meta ?value] $def] - (|case (&meta/meta-get &meta/type?-tag ?meta) - (&/$Some _) - (return* state (&/T [(|case (&meta/meta-get &meta/export?-tag ?meta) - (&/$Some _) - true - - _ - false) - ?value])) - - _ - ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])))) - state))) - ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T [module name])))) - state)) - ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module)) - state)))) - -(defn exists? - "(-> Text (Lux Bool))" - [name] - (fn [state] - (return* state - (->> state (&/get$ &/$modules) (&/|contains? name))))) - -(defn dealias [name] - (|do [current-module &/get-module-name] - (fn [state] - (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] - (return* state real-name) - ((&/fail-with-loc (str "[Analyser Error] Unknown alias: " name)) - state))))) - -(defn alias [module alias reference] - (fn [state] - (let [_module_ (->> state (&/get$ &/$modules) (&/|get module))] - (if (&/|member? module (->> _module_ (&/get$ $imports))) - ((&/fail-with-loc (str "[Analyser Error] Can't create alias that is the same as a module nameL " (pr-str alias) " for " reference)) - state) - (if-let [real-name (->> _module_ (&/get$ $module-aliases) (&/|get alias))] - ((&/fail-with-loc (str "[Analyser Error] Can't re-use alias \"" alias "\" @ " module)) - state) - (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - #(&/update$ $module-aliases - (fn [aliases] - (&/|put alias reference aliases)) - %) - ms)))) - nil)))) - )) - -(defn ^:private imports? [state imported-module-name source-module-name] - (->> state - (&/get$ &/$modules) - (&/|get source-module-name) - (&/get$ $imports) - (&/|any? (partial = imported-module-name)))) - -(defn get-anns [module-name] - (fn [state] - (if-let [module (->> state - (&/get$ &/$modules) - (&/|get module-name))] - (return* state (&/get$ $module-anns module)) - ((&/fail-with-loc (str "[Analyser Error] Module does not exist: " module-name)) - state)))) - -(defn set-anns [anns module-name] - (fn [state] - (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module-name - #(&/set$ $module-anns anns %) - ms)))) - nil))) - -(defn find-def [module name] - (|do [current-module &/get-module-name] - (fn [state] - (if (or (= "lux" module) - (= current-module module) - (imports? state module current-module)) - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|let [[?type ?meta ?value] $def] - (if (.equals ^Object current-module module) - (|case (&meta/meta-get &meta/alias-tag ?meta) - (&/$Some (&/$IdentM [?r-module ?r-name])) - ((find-def ?r-module ?r-name) - state) - - _ - (return* state (&/T [(&/T [module name]) $def]))) - (|case (&meta/meta-get &meta/export?-tag ?meta) - (&/$Some (&/$BoolM true)) - (return* state (&/T [(&/T [module name]) $def])) - - _ - ((&/fail-with-loc (str "[Analyser Error @ find-def] Can't use unexported definition: " (str module &/+name-separator+ name))) - state)))) - ((&/fail-with-loc (str "[Analyser Error @ find-def] Definition does not exist: " (str module &/+name-separator+ name))) - state)) - ((&/fail-with-loc (str "[Analyser Error @ find-def] Module doesn't exist: " module)) - state)) - ((&/fail-with-loc (str "[Analyser Error @ find-def] Unknown module: " module)) - state)) - ))) - -(defn ensure-type-def - "(-> DefData (Lux Type))" - [def-data] - (|let [[?type ?meta ?value] def-data] - (|case (&meta/meta-get &meta/type?-tag ?meta) - (&/$Some _) - (return ?type) - - _ - (&/fail-with-loc (str "[Analyser Error] Not a type definition: " (&/adt->text def-data)))))) - -(defn defined? [module name] - (&/try-all% (&/|list (|do [_ (find-def module name)] - (return true)) - (return false)))) - -(defn create-module - "(-> Text Hash-Code (Lux Null))" - [name hash] - (fn [state] - (return* (->> state - (&/update$ &/$modules #(&/|put name (new-module hash) %)) - (&/set$ &/$scopes (&/|list (&/env name &/$Nil)))) - nil))) - -(do-template [ ] - (defn - - [module] - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (return* state (&/get$ =module)) - ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) - state)) - )) - - tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" - types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" - module-hash $module-hash "(-> Text (Lux Int))" - ) - -(def imports - (|do [module &/get-module-name - _imports (fn [state] - (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports))))] - (&/map% (fn [_module] - (|do [_hash (module-hash _module)] - (return (&/T [_module _hash])))) - _imports))) - -(defn ensure-undeclared-tags [module tags] - (|do [tags-table (tags-by-module module) - _ (&/map% (fn [tag] - (if (&/|get tag tags-table) - (&/fail-with-loc (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T [module tag])))) - (return nil))) - tags)] - (return nil))) - -(defn ensure-undeclared-type [module name] - (|do [types-table (types-by-module module) - _ (&/assert! (nil? (&/|get name types-table)) - (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T [module name]))))] - (return nil))) - -(defn declare-tags - "(-> Text (List Text) Bool Type (Lux Null))" - [module tag-names was-exported? type] - (|do [_ (ensure-undeclared-tags module tag-names) - type-name (&type/type-name type) - :let [[_module _name] type-name] - _ (&/assert! (= module _module) - (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name))) - _ (ensure-undeclared-type _module _name)] - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (let [tags (&/|map (fn [tag-name] (&/T [module tag-name])) tag-names)] - (return* (&/update$ &/$modules - (fn [=modules] - (&/|update module - #(->> % - (&/set$ $tags (&/fold (fn [table idx+tag-name] - (|let [[idx tag-name] idx+tag-name] - (&/|put tag-name (&/T [idx tags was-exported? type]) table))) - (&/get$ $tags %) - (&/enumerate tag-names))) - (&/update$ $types (partial &/|put _name (&/T [tags was-exported? type])))) - =modules)) - state) - nil)) - ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) - state))))) - -(defn ensure-can-see-tag - "(-> Text Text (Lux Unit))" - [module tag-name] - (|do [current-module &/get-module-name] - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))] - (|let [[?idx ?tags ?exported ?type] idx+tags+exported+type] - (if (or ?exported - (= module current-module)) - (return* state &/unit-tag) - ((&/fail-with-loc (str "[Analyser Error] Can't access tag #" (&/ident->text (&/T [module tag-name])) " from module " current-module)) - state))) - ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name])))) - state)) - ((&/fail-with-loc (str "[Module Error] Unknown module: " module)) - state))))) - -(do-template [ ] - (defn - - [module tag-name] - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))] - (|let [[?idx ?tags ?exported ?type] idx+tags+exported+type] - (return* state )) - ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name])))) - state)) - ((&/fail-with-loc (str "[Module Error] Unknown module: " module)) - state)))) - - tag-index ?idx "(-> Text Text (Lux Int))" - tag-group ?tags "(-> Text Text (Lux (List Ident)))" - tag-type ?type "(-> Text Text (Lux Type))" - ) - -(def defs - (|do [module &/get-module-name] - (fn [state] - (return* state - (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) - (&/|map (fn [kv] - (|let [[k _def-data] kv - [_ ?def-meta _] _def-data] - (|case (&meta/meta-get &meta/alias-tag ?def-meta) - (&/$Some (&/$IdentM [?r-module ?r-name])) - (&/T [k (str ?r-module ";" ?r-name) _def-data]) - - _ - (&/T [k "" _def-data]) - ))))))))) - -(do-template [ ] - (defn [module name meta type] - (|case (&meta/meta-get meta) - (&/$Some (&/$BoolM true)) - (&/try-all% (&/|list (&type/check type) - (&/fail-with-loc (str "[Analyser Error] Can't tag as lux;" "? if it's not a " ": " (str module ";" name))))) - - _ - (return nil))) - - test-type &type/Type &meta/type?-tag "type" - test-macro &type/Macro &meta/macro?-tag "macro" - ) - -(defn fetch-imports [meta] - (|case (&meta/meta-get &meta/imports-tag meta) - (&/$Some (&/$ListM _parts)) - (&/map% (fn [_part] - (|case _part - (&/$ListM (&/$Cons [(&/$TextM _module) - (&/$Cons [(&/$TextM _alias) - (&/$Nil)])])) - (return (&/T [_module _alias])) - - _ - (&/fail-with-loc "[Analyser Error] Wrong import syntax."))) - _parts) - - _ - (&/fail-with-loc "[Analyser Error] No import meta-data."))) diff --git a/src/lux/analyser/parser.clj b/src/lux/analyser/parser.clj deleted file mode 100644 index e60f28a02..000000000 --- a/src/lux/analyser/parser.clj +++ /dev/null @@ -1,469 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.analyser.parser - (:require (clojure [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]] - [reader :as &reader] - [lexer :as &lexer] - [parser :as &parser]))) - -(declare parse-gclass) - -;; [Parsers] -(def ^:private _space_ (&reader/read-text " ")) - -(defn ^:private repeat% [action] - (fn [state] - (|case (action state) - (&/$Left ^String error) - (&/$Right (&/T [state &/$Nil])) - - (&/$Right state* head) - ((|do [tail (repeat% action)] - (return (&/$Cons head tail))) - state*)))) - -(defn ^:private spaced [action] - (fn [state] - (|case (action state) - (&/$Left ^String error) - (&/$Right (&/T [state &/$Nil])) - - (&/$Right state* head) - ((&/try-all% (&/|list (|do [_ _space_ - tail (spaced action)] - (return (&/$Cons head tail))) - (return (&/|list head)))) - state*)))) - -(def ^:private parse-name - (|do [[_ _ =name] (&reader/read-regex #"^([a-zA-Z0-9_\.]+)")] - (return =name))) - -(def ^:private parse-ident - (|do [[_ _ =name] (&reader/read-regex &lexer/+ident-re+)] - (return =name))) - -(defn ^:private with-parens [body] - (|do [_ (&reader/read-text "(") - output body - _ (&reader/read-text ")")] - (return output))) - -(defn ^:private with-brackets [body] - (|do [_ (&reader/read-text "[") - output body - _ (&reader/read-text "]")] - (return output))) - -(defn ^:private with-braces [body] - (|do [_ (&reader/read-text "{") - output body - _ (&reader/read-text "}")] - (return output))) - -(def ^:private parse-type-param - (with-parens - (|do [=name parse-name - _ _space_ - =bounds (spaced parse-gclass)] - (return (&/T [=name =bounds]))))) - -(def ^:private parse-gclass-decl - (with-parens - (|do [=class-name parse-name - _ _space_ - =params (spaced parse-type-param)] - (return (&/T [=class-name =params]))))) - -(def ^:private parse-bound-kind - (&/try-all% (&/|list (|do [_ (&reader/read-text "<")] - (return &/$UpperBound)) - - (|do [_ (&reader/read-text ">")] - (return &/$LowerBound)) - ))) - -(def parse-gclass - (&/try-all% (&/|list (|do [=bound-kind parse-bound-kind - =bound parse-gclass] - (return (&/$GenericWildcard (&/$Some (&/T [=bound-kind =bound]))))) - - (|do [_ (&reader/read-text "?")] - (return (&/$GenericWildcard &/$None))) - - (|do [var-name parse-name] - (return (&/$GenericTypeVar var-name))) - - (with-parens - (|do [class-name parse-name - _ _space_ - =params (spaced parse-gclass)] - (return (&/$GenericClass class-name =params)))) - - (with-parens - (|do [_ (&reader/read-text "Array") - _ _space_ - =param parse-gclass] - (return (&/$GenericArray =param)))) - ))) - -(def ^:private parse-gclass-super - (with-parens - (|do [class-name parse-name - _ _space_ - =params (spaced parse-gclass)] - (return (&/T [class-name =params]))))) - -(def ^:private parse-ctor-arg - (with-brackets - (|do [=class parse-gclass - (&/$Cons =term (&/$Nil)) &parser/parse] - (return (&/T [=class =term]))))) - -(def ^:private parse-ann-param - (|do [param-name parse-name - _ (&reader/read-text "=") - param-value (&/try-all% (&/|list (|do [[_ (&lexer/$Bool param-value*)] &lexer/lex-bool] - (return (boolean param-value*))) - - (|do [[_ (&lexer/$Int param-value*)] &lexer/lex-int] - (return (int param-value*))) - - (|do [_ (&reader/read-text "l") - [_ (&lexer/$Int param-value*)] &lexer/lex-int] - (return (long param-value*))) - - (|do [[_ (&lexer/$Real param-value*)] &lexer/lex-real] - (return (float param-value*))) - - (|do [_ (&reader/read-text "d") - [_ (&lexer/$Real param-value*)] &lexer/lex-real] - (return (double param-value*))) - - (|do [[_ (&lexer/$Char param-value*)] &lexer/lex-char] - (return (char param-value*))) - - (|do [[_ (&lexer/$Text param-value*)] &lexer/lex-text] - (return param-value*)) - ))] - (return (&/T [param-name param-value])))) - -(def ^:private parse-ann - (with-parens - (|do [ann-name parse-name - _ _space_ - =ann-params (with-braces - (spaced parse-ann-param))] - (return {:name ann-name - :params =ann-params})))) - -(def ^:private parse-arg-decl - (with-parens - (|do [=arg-name parse-ident - _ (&reader/read-text " ") - =gclass parse-gclass] - (return (&/T [=arg-name =gclass]))))) - -(def ^:private parse-gvars - (|do [=head parse-name - [_ _ ?] (&reader/read-text? " ")] - (if ? - (|do [=tail parse-gvars] - (return (&/$Cons =head =tail))) - (return (&/|list =head))))) - -(def ^:private parse-method-decl - (with-parens - (|do [=method-name parse-name - _ _space_ - =anns (with-brackets - (spaced parse-ann)) - _ _space_ - =gvars (with-brackets - parse-gvars) - _ _space_ - =exceptions (with-brackets - (spaced parse-gclass)) - _ _space_ - =inputs (with-brackets - (spaced parse-gclass)) - _ _space_ - =output parse-gclass] - (return (&/T [=method-name =anns =gvars =exceptions =inputs =output]))))) - -(def ^:private parse-privacy-modifier - (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] - (return &/$DefaultPM)) - - (|do [_ (&reader/read-text "public")] - (return &/$PublicPM)) - - (|do [_ (&reader/read-text "protected")] - (return &/$ProtectedPM)) - - (|do [_ (&reader/read-text "private")] - (return &/$PrivatePM)) - ))) - -(def ^:private parse-state-modifier - (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] - (return &/$DefaultSM)) - - (|do [_ (&reader/read-text "volatile")] - (return &/$VolatileSM)) - - (|do [_ (&reader/read-text "final")] - (return &/$FinalSM)) - ))) - -(def ^:private parse-inheritance-modifier - (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] - (return &/$DefaultIM)) - - (|do [_ (&reader/read-text "abstract")] - (return &/$AbstractIM)) - - (|do [_ (&reader/read-text "final")] - (return &/$FinalIM)) - ))) - -(def ^:private parse-method-init-def - (|do [_ (&reader/read-text "init") - _ _space_ - =privacy-modifier parse-privacy-modifier - _ _space_ - [_ (&lexer/$Bool =strict*)] &lexer/lex-bool - :let [=strict (Boolean/parseBoolean =strict*)] - _ _space_ - =anns (with-brackets - (spaced parse-ann)) - _ _space_ - =gvars (with-brackets - (spaced parse-type-param)) - _ _space_ - =exceptions (with-brackets - (spaced parse-gclass)) - _ _space_ - =inputs (with-brackets - (spaced parse-arg-decl)) - _ _space_ - =ctor-args (with-brackets - (spaced parse-ctor-arg)) - _ _space_ - (&/$Cons =body (&/$Nil)) &parser/parse] - (return (&/$ConstructorMethodSyntax (&/T [=privacy-modifier =strict =anns =gvars =exceptions =inputs =ctor-args =body]))))) - -(def ^:private parse-method-virtual-def - (|do [_ (&reader/read-text "virtual") - _ _space_ - =name parse-name - _ _space_ - =privacy-modifier parse-privacy-modifier - _ _space_ - [_ (&lexer/$Bool =final?*)] &lexer/lex-bool - :let [=final? (Boolean/parseBoolean =final?*)] - _ _space_ - [_ (&lexer/$Bool =strict*)] &lexer/lex-bool - :let [=strict (Boolean/parseBoolean =strict*)] - _ _space_ - =anns (with-brackets - (spaced parse-ann)) - _ _space_ - =gvars (with-brackets - (spaced parse-type-param)) - _ _space_ - =exceptions (with-brackets - (spaced parse-gclass)) - _ _space_ - =inputs (with-brackets - (spaced parse-arg-decl)) - _ _space_ - =output parse-gclass - _ _space_ - (&/$Cons =body (&/$Nil)) &parser/parse] - (return (&/$VirtualMethodSyntax (&/T [=name =privacy-modifier =final? =strict =anns =gvars =exceptions =inputs =output =body]))))) - -(def ^:private parse-method-override-def - (|do [_ (&reader/read-text "override") - _ _space_ - =class-decl parse-gclass-decl - _ _space_ - =name parse-name - _ _space_ - [_ (&lexer/$Bool =strict*)] &lexer/lex-bool - :let [=strict (Boolean/parseBoolean =strict*)] - _ _space_ - =anns (with-brackets - (spaced parse-ann)) - _ _space_ - =gvars (with-brackets - (spaced parse-type-param)) - _ _space_ - =exceptions (with-brackets - (spaced parse-gclass)) - _ _space_ - =inputs (with-brackets - (spaced parse-arg-decl)) - _ _space_ - =output parse-gclass - _ _space_ - (&/$Cons =body (&/$Nil)) &parser/parse] - (return (&/$OverridenMethodSyntax (&/T [=class-decl =name =strict =anns =gvars =exceptions =inputs =output =body]))))) - -(def ^:private parse-method-static-def - (|do [_ (&reader/read-text "static") - _ _space_ - =name parse-name - _ _space_ - =privacy-modifier parse-privacy-modifier - _ _space_ - [_ (&lexer/$Bool =strict*)] &lexer/lex-bool - :let [=strict (Boolean/parseBoolean =strict*)] - _ _space_ - =anns (with-brackets - (spaced parse-ann)) - _ _space_ - =gvars (with-brackets - (spaced parse-type-param)) - _ _space_ - =exceptions (with-brackets - (spaced parse-gclass)) - _ _space_ - =inputs (with-brackets - (spaced parse-arg-decl)) - _ _space_ - =output parse-gclass - _ _space_ - (&/$Cons =body (&/$Nil)) &parser/parse] - (return (&/$StaticMethodSyntax (&/T [=name =privacy-modifier =strict =anns =gvars =exceptions =inputs =output =body]))))) - -(def ^:private parse-method-abstract-def - (|do [_ (&reader/read-text "abstract") - _ _space_ - =name parse-name - _ _space_ - =privacy-modifier parse-privacy-modifier - _ _space_ - =anns (with-brackets - (spaced parse-ann)) - _ _space_ - =gvars (with-brackets - (spaced parse-type-param)) - _ _space_ - =exceptions (with-brackets - (spaced parse-gclass)) - _ _space_ - =inputs (with-brackets - (spaced parse-arg-decl)) - _ _space_ - =output parse-gclass] - (return (&/$AbstractMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output]))))) - -(def ^:private parse-method-native-def - (|do [_ (&reader/read-text "native") - _ _space_ - =name parse-name - _ _space_ - =privacy-modifier parse-privacy-modifier - _ _space_ - =anns (with-brackets - (spaced parse-ann)) - _ _space_ - =gvars (with-brackets - (spaced parse-type-param)) - _ _space_ - =exceptions (with-brackets - (spaced parse-gclass)) - _ _space_ - =inputs (with-brackets - (spaced parse-arg-decl)) - _ _space_ - =output parse-gclass] - (return (&/$NativeMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output]))))) - -(def ^:private parse-method-def - (with-parens - (&/try-all% (&/|list parse-method-init-def - parse-method-virtual-def - parse-method-override-def - parse-method-static-def - parse-method-abstract-def - parse-method-native-def - )))) - -(def ^:private parse-field - (with-parens - (&/try-all% (&/|list (|do [_ (&reader/read-text "constant") - _ _space_ - =name parse-name - _ _space_ - =anns (with-brackets - (spaced parse-ann)) - _ _space_ - =type parse-gclass - _ _space_ - (&/$Cons =value (&/$Nil)) &parser/parse] - (return (&/$ConstantFieldSyntax =name =anns =type =value))) - - (|do [_ (&reader/read-text "variable") - _ _space_ - =name parse-name - _ _space_ - =privacy-modifier parse-privacy-modifier - _ _space_ - =state-modifier parse-state-modifier - _ _space_ - =anns (with-brackets - (spaced parse-ann)) - _ _space_ - =type parse-gclass] - (return (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type))) - )))) - -(def parse-interface-def - (|do [=gclass-decl parse-gclass-decl - =supers (with-brackets - (spaced parse-gclass-super)) - =anns (with-brackets - (spaced parse-ann)) - =methods (spaced parse-method-decl)] - (return (&/T [=gclass-decl =supers =anns =methods])))) - -(def parse-class-def - (|do [=gclass-decl parse-gclass-decl - _ _space_ - =super-class parse-gclass-super - _ _space_ - =interfaces (with-brackets - (spaced parse-gclass-super)) - _ _space_ - =inheritance-modifier parse-inheritance-modifier - _ _space_ - =anns (with-brackets - (spaced parse-ann)) - _ _space_ - =fields (with-brackets - (spaced parse-field)) - _ _space_ - =methods (with-brackets - (spaced parse-method-def))] - (return (&/T [=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods])))) - -(def parse-anon-class-def - (|do [=super-class parse-gclass-super - _ _space_ - =interfaces (with-brackets - (spaced parse-gclass-super)) - _ _space_ - =ctor-args (with-brackets - (spaced parse-ctor-arg)) - _ _space_ - =methods (with-brackets - (spaced parse-method-def))] - (return (&/T [=super-class =interfaces =ctor-args =methods])))) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj deleted file mode 100644 index 81332b34c..000000000 --- a/src/lux/analyser/record.clj +++ /dev/null @@ -1,47 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.analyser.record - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case]] - [type :as &type]) - (lux.analyser [base :as &&] - [module :as &&module]))) - -;; [Exports] -(defn order-record [pairs] - "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" - (|do [[tag-group tag-type] (|case pairs - (&/$Nil) - (return (&/T [&/$Nil &/$UnitT])) - - (&/$Cons [[_ (&/$TagS tag1)] _] _) - (|do [[module name] (&&/resolved-ident tag1) - tags (&&module/tag-group module name) - type (&&module/tag-type module name)] - (return (&/T [tags type]))) - - _ - (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) - =pairs (&/map% (fn [kv] - (|case kv - [[_ (&/$TagS k)] v] - (|do [=k (&&/resolved-ident k)] - (return (&/T [(&/ident->text =k) v]))) - - _ - (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) - pairs) - _ (let [num-expected (&/|length tag-group) - num-got (&/|length =pairs)] - (&/assert! (= num-expected num-got) - (str "[Analyser Error] Wrong number of record members. Expected " num-expected ", but got " num-got "."))) - =members (&/map% (fn [tag] - (if-let [member (&/|get tag =pairs)] - (return member) - (&/fail-with-loc (str "[Analyser Error] Missing tag: " tag)))) - (&/|map &/ident->text tag-group))] - (return (&/T [=members tag-type])))) diff --git a/src/lux/base.clj b/src/lux/base.clj deleted file mode 100644 index 5697415f8..000000000 --- a/src/lux/base.clj +++ /dev/null @@ -1,1449 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.base - (:require (clojure [template :refer [do-template]] - [string :as string]) - [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array)) - -;; [Tags] -(def unit-tag (.intern (str (char 0) "unit" (char 0)))) - -(defn T [elems] - (case (count elems) - 0 - unit-tag - - 1 - (first elems) - - ;; else - (to-array elems))) - -(defmacro defvariant [& names] - (assert (> (count names) 1)) - `(do ~@(for [[[name num-params] idx] (map vector names (range (count names))) - :let [last-idx (dec (count names)) - is-last? (if (= idx last-idx) - "" - nil) - def-name (with-meta (symbol (str "$" name)) - {::idx idx - ::is-last? is-last?})]] - (cond (= 0 num-params) - `(def ~def-name - (to-array [(int ~idx) ~is-last? unit-tag])) - - (= 1 num-params) - `(defn ~def-name [arg#] - (to-array [(int ~idx) ~is-last? arg#])) - - :else - (let [g!args (map (fn [_] (gensym "arg")) - (range num-params))] - `(defn ~def-name [~@g!args] - (to-array [(int ~idx) ~is-last? (T [~@g!args])]))) - )))) - -(defmacro deftuple [names] - (assert (vector? names)) - `(do ~@(for [[name idx] (map vector names (range (count names)))] - `(def ~(symbol (str "$" name)) - (int ~idx))))) - -;; List -(defvariant - ("Nil" 0) - ("Cons" 2)) - -;; Maybe -(defvariant - ("None" 0) - ("Some" 1)) - -;; Either -(defvariant - ("Left" 1) - ("Right" 1)) - -;; AST -(defvariant - ("BoolS" 1) - ("NatS" 1) - ("IntS" 1) - ("FracS" 1) - ("RealS" 1) - ("CharS" 1) - ("TextS" 1) - ("SymbolS" 1) - ("TagS" 1) - ("FormS" 1) - ("TupleS" 1) - ("RecordS" 1)) - -;; Type -(defvariant - ("HostT" 2) - ("VoidT" 0) - ("UnitT" 0) - ("SumT" 2) - ("ProdT" 2) - ("LambdaT" 2) - ("BoundT" 1) - ("VarT" 1) - ("ExT" 1) - ("UnivQ" 2) - ("ExQ" 2) - ("AppT" 2) - ("NamedT" 2)) - -;; Vars -(defvariant - ("Local" 1) - ("Global" 1)) - -;; Binding -(deftuple - ["counter" - "mappings"]) - -;; Env -(deftuple - ["name" - "inner-closures" - "locals" - "closure"]) - -;; ModuleState -(defvariant - ("Active" 0) - ("Compiled" 0) - ("Cached" 0)) - -;; Host -(deftuple - ["writer" - "loader" - "classes" - "catching" - "module-states" - "type-env" - "dummy-mappings" - ]) - -;; Compiler -(defvariant - ("Release" 0) - ("Debug" 0) - ("Eval" 0) - ("REPL" 0)) - -(deftuple - ["compiler-name" - "compiler-version" - "compiler-mode"]) - -(deftuple - ["info" - "source" - "cursor" - "modules" - "scopes" - "type-vars" - "expected" - "seed" - "scope-type-vars" - "host"]) - -;; Compiler -(defvariant - ("UpperBound" 0) - ("LowerBound" 0)) - -(defvariant - ("GenericTypeVar" 1) - ("GenericClass" 2) - ("GenericArray" 1) - ("GenericWildcard" 1)) - -;; Privacy Modifiers -(defvariant - ("DefaultPM" 0) - ("PublicPM" 0) - ("PrivatePM" 0) - ("ProtectedPM" 0)) - -;; State Modifiers -(defvariant - ("DefaultSM" 0) - ("VolatileSM" 0) - ("FinalSM" 0)) - -;; Inheritance Modifiers -(defvariant - ("DefaultIM" 0) - ("AbstractIM" 0) - ("FinalIM" 0)) - -;; Fields -(defvariant - ("ConstantFieldSyntax" 4) - ("VariableFieldSyntax" 5)) - -(defvariant - ("ConstantFieldAnalysis" 4) - ("VariableFieldAnalysis" 5)) - -;; Methods -(defvariant - ("ConstructorMethodSyntax" 1) - ("VirtualMethodSyntax" 1) - ("OverridenMethodSyntax" 1) - ("StaticMethodSyntax" 1) - ("AbstractMethodSyntax" 1) - ("NativeMethodSyntax" 1)) - -(defvariant - ("ConstructorMethodAnalysis" 1) - ("VirtualMethodAnalysis" 1) - ("OverridenMethodAnalysis" 1) - ("StaticMethodAnalysis" 1) - ("AbstractMethodAnalysis" 1) - ("NativeMethodAnalysis" 1)) - -;; Meta-data -(defvariant - ("BoolM" 1) - ("NatM" 1) - ("IntM" 1) - ("FracM" 1) - ("RealM" 1) - ("CharM" 1) - ("TextM" 1) - ("IdentM" 1) - ("ListM" 1) - ("DictM" 1)) - -;; [Exports] -(def ^:const name-field "_name") -(def ^:const hash-field "_hash") -(def ^:const value-field "_value") -(def ^:const compiler-field "_compiler") -(def ^:const eval-field "_eval") -(def ^:const module-class-name "_") -(def ^:const +name-separator+ ";") - -(def ^:const ^String compiler-name "Lux/JVM") -(def ^:const ^String compiler-version "0.5.0") - -;; Constructors -(def empty-cursor (T ["" -1 -1])) - -(defn get$ [slot ^objects record] - (aget record slot)) - -(defn set$ [slot value ^objects record] - (doto (aclone ^objects record) - (aset slot value))) - -(defmacro update$ [slot f record] - `(let [record# ~record] - (set$ ~slot (~f (get$ ~slot record#)) - record#))) - -(defn fail* [message] - ($Left message)) - -(defn return* [state value] - ($Right (T [state value]))) - -(defn transform-pattern [pattern] - (cond (vector? pattern) (case (count pattern) - 0 - unit-tag - - 1 - (transform-pattern (first pattern)) - - ;; else - (mapv transform-pattern pattern)) - (seq? pattern) [(if-let [tag-var (ns-resolve *ns* (first pattern))] - (-> tag-var - meta - ::idx) - (assert false (str "Unknown var: " (first pattern)))) - '_ - (transform-pattern (vec (rest pattern)))] - :else pattern - )) - -(defmacro |case [value & branches] - (assert (= 0 (mod (count branches) 2))) - (let [value* (if (vector? value) - [`(T [~@value])] - [value])] - `(matchv ::M/objects ~value* - ~@(mapcat (fn [[pattern body]] - (list [(transform-pattern pattern)] - body)) - (partition 2 branches))))) - -(defmacro |let [bindings body] - (reduce (fn [inner [left right]] - `(|case ~right - ~left - ~inner)) - body - (reverse (partition 2 bindings)))) - -(defmacro |list [& elems] - (reduce (fn [tail head] - `($Cons ~head ~tail)) - `$Nil - (reverse elems))) - -(defmacro |table [& elems] - (reduce (fn [table [k v]] - `(|put ~k ~v ~table)) - `$Nil - (reverse (partition 2 elems)))) - -(defn |get [slot table] - (|case table - ($Nil) - nil - - ($Cons [k v] table*) - (if (.equals ^Object k slot) - v - (recur slot table*)))) - -(defn |put [slot value table] - (|case table - ($Nil) - ($Cons (T [slot value]) $Nil) - - ($Cons [k v] table*) - (if (.equals ^Object k slot) - ($Cons (T [slot value]) table*) - ($Cons (T [k v]) (|put slot value table*))) - )) - -(defn |remove [slot table] - (|case table - ($Nil) - table - - ($Cons [k v] table*) - (if (.equals ^Object k slot) - table* - ($Cons (T [k v]) (|remove slot table*))))) - -(defn |update [k f table] - (|case table - ($Nil) - table - - ($Cons [k* v] table*) - (if (.equals ^Object k k*) - ($Cons (T [k* (f v)]) table*) - ($Cons (T [k* v]) (|update k f table*))))) - -(defn |head [xs] - (|case xs - ($Nil) - (assert false (prn-str '|head)) - - ($Cons x _) - x)) - -(defn |tail [xs] - (|case xs - ($Nil) - (assert false (prn-str '|tail)) - - ($Cons _ xs*) - xs*)) - -;; [Resources/Monads] -(defn fail [message] - (fn [_] - ($Left message))) - -(defn return [value] - (fn [state] - ($Right (T [state value])))) - -(defn bind [m-value step] - (fn [state] - (let [inputs (m-value state)] - (|case inputs - ($Right ?state ?datum) - ((step ?datum) ?state) - - ($Left _) - inputs - )))) - -(defmacro |do [steps return] - (assert (= 0 (rem (count steps) 2)) "The number of steps must be even!") - (reduce (fn [inner [label computation]] - (case label - :let `(|let ~computation ~inner) - ;; else - `(bind ~computation - (fn [val#] - (|case val# - ~label - ~inner))))) - return - (reverse (partition 2 steps)))) - -;; [Resources/Combinators] -(let [array-class (class (to-array []))] - (defn adt->text [adt] - (if (= array-class (class adt)) - (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") - (pr-str adt)))) - -(defn |++ [xs ys] - (|case xs - ($Nil) - ys - - ($Cons x xs*) - ($Cons x (|++ xs* ys)))) - -(defn |map [f xs] - (|case xs - ($Nil) - xs - - ($Cons x xs*) - ($Cons (f x) (|map f xs*)) - - _ - (assert false (prn-str '|map f (adt->text xs))))) - -(defn |empty? [xs] - "(All [a] (-> (List a) Bool))" - (|case xs - ($Nil) - true - - ($Cons _ _) - false)) - -(defn |filter [p xs] - "(All [a] (-> (-> a Bool) (List a) (List a)))" - (|case xs - ($Nil) - xs - - ($Cons x xs*) - (if (p x) - ($Cons x (|filter p xs*)) - (|filter p xs*)))) - -(defn flat-map [f xs] - "(All [a b] (-> (-> a (List b)) (List a) (List b)))" - (|case xs - ($Nil) - xs - - ($Cons x xs*) - (|++ (f x) (flat-map f xs*)))) - -(defn |split-with [p xs] - (|case xs - ($Nil) - (T [xs xs]) - - ($Cons x xs*) - (if (p x) - (|let [[pre post] (|split-with p xs*)] - (T [($Cons x pre) post])) - (T [$Nil xs])))) - -(defn |contains? [k table] - (|case table - ($Nil) - false - - ($Cons [k* _] table*) - (or (.equals ^Object k k*) - (|contains? k table*)))) - -(defn |member? [x xs] - (|case xs - ($Nil) - false - - ($Cons x* xs*) - (or (= x x*) (|member? x xs*)))) - -(defn fold [f init xs] - (|case xs - ($Nil) - init - - ($Cons x xs*) - (recur f (f init x) xs*))) - -(defn fold% [f init xs] - (|case xs - ($Nil) - (return init) - - ($Cons x xs*) - (|do [init* (f init x)] - (fold% f init* xs*)))) - -(defn folds [f init xs] - (|case xs - ($Nil) - (|list init) - - ($Cons x xs*) - ($Cons init (folds f (f init x) xs*)))) - -(defn |length [xs] - (fold (fn [acc _] (inc acc)) 0 xs)) - -(defn |range* [from to] - (if (<= from to) - ($Cons from (|range* (inc from) to)) - $Nil)) - -(let [|range* (fn |range* [from to] - (if (< from to) - ($Cons from (|range* (inc from) to)) - $Nil))] - (defn |range [n] - (|range* 0 n))) - -(defn |first [pair] - (|let [[_1 _2] pair] - _1)) - -(defn |second [pair] - (|let [[_1 _2] pair] - _2)) - -(defn zip2 [xs ys] - (|case [xs ys] - [($Cons x xs*) ($Cons y ys*)] - ($Cons (T [x y]) (zip2 xs* ys*)) - - [_ _] - $Nil)) - -(defn |keys [plist] - (|case plist - ($Nil) - $Nil - - ($Cons [k v] plist*) - ($Cons k (|keys plist*)))) - -(defn |vals [plist] - (|case plist - ($Nil) - $Nil - - ($Cons [k v] plist*) - ($Cons v (|vals plist*)))) - -(defn |interpose [sep xs] - (|case xs - ($Nil) - xs - - ($Cons _ ($Nil)) - xs - - ($Cons x xs*) - ($Cons x ($Cons sep (|interpose sep xs*))))) - -(do-template [ ] - (defn [f xs] - (|case xs - ($Nil) - (return xs) - - ($Cons x xs*) - (|do [y (f x) - ys ( f xs*)] - (return ( y ys))))) - - map% $Cons - flat-map% |++) - -(defn list-join [xss] - (fold |++ $Nil xss)) - -(defn |as-pairs [xs] - (|case xs - ($Cons x ($Cons y xs*)) - ($Cons (T [x y]) (|as-pairs xs*)) - - _ - $Nil)) - -(defn |reverse [xs] - (fold (fn [tail head] - ($Cons head tail)) - $Nil - xs)) - -(defn add-loc [meta ^String msg] - (if (.startsWith msg "@") - msg - (|let [[file line col] meta] - (str "@ " file "," line "," col "\n" msg)))) - -(defn fail-with-loc [msg] - (fn [state] - (fail* (add-loc (get$ $cursor state) msg)))) - -(defn assert! [test message] - (if test - (return unit-tag) - (fail-with-loc message))) - -(def get-state - (fn [state] - (return* state state))) - -(defn try-all% [monads] - (|case monads - ($Nil) - (fail "There are no alternatives to try!") - - ($Cons m monads*) - (fn [state] - (let [output (m state)] - (|case [output monads*] - [($Right _) _] - output - - [_ ($Nil)] - output - - [_ _] - ((try-all% monads*) state) - ))) - )) - -(defn try-all-% [prefix monads] - (|case monads - ($Nil) - (fail "There are no alternatives to try!") - - ($Cons m monads*) - (fn [state] - (let [output (m state)] - (|case [output monads*] - [($Right _) _] - output - - [_ ($Nil)] - output - - [($Left ^String error) _] - (if (.contains error prefix) - ((try-all-% prefix monads*) state) - output) - ))) - )) - -(defn exhaust% [step] - (fn [state] - (|case (step state) - ($Right state* _) - ((exhaust% step) state*) - - ($Left msg) - (if (.equals "[Reader Error] EOF" msg) - (return* state unit-tag) - (fail* msg))))) - -(defn ^:private normalize-char [char] - (case char - \* "_ASTER_" - \+ "_PLUS_" - \- "_DASH_" - \/ "_SLASH_" - \\ "_BSLASH_" - \_ "_UNDERS_" - \% "_PERCENT_" - \$ "_DOLLAR_" - \' "_QUOTE_" - \` "_BQUOTE_" - \@ "_AT_" - \^ "_CARET_" - \& "_AMPERS_" - \= "_EQ_" - \! "_BANG_" - \? "_QM_" - \: "_COLON_" - \. "_PERIOD_" - \, "_COMMA_" - \< "_LT_" - \> "_GT_" - \~ "_TILDE_" - \| "_PIPE_" - ;; default - char)) - -(defn normalize-name [ident] - (reduce str "" (map normalize-char ident))) - -(def classes - (fn [state] - (return* state (->> state (get$ $host) (get$ $classes))))) - -(def +init-bindings+ - (T [;; "lux;counter" - 0 - ;; "lux;mappings" - (|table)])) - -(defn env [name old-name] - (T [;; "lux;name" - ($Cons name old-name) - ;; "lux;inner-closures" - 0 - ;; "lux;locals" - +init-bindings+ - ;; "lux;closure" - +init-bindings+] - )) - -(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String - (class (byte-array [])) - Integer/TYPE - Integer/TYPE])) - (.setAccessible true))] - (defn memory-class-loader [store] - (proxy [java.lang.ClassLoader] - [] - (findClass [^String class-name] - (if-let [^bytes bytecode (get @store class-name)] - (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) - (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))) - -(def loader - (fn [state] - (return* state (->> state (get$ $host) (get$ $loader))))) - -(defn host [_] - (let [store (atom {})] - (T [;; "lux;writer" - $None - ;; "lux;loader" - (memory-class-loader store) - ;; "lux;classes" - store - ;; "lux;catching" - $Nil - ;; "lux;module-states" - (|table) - ;; lux;type-env - (|table) - ;; lux;dummy-mappings - (|table) - ]))) - -(defn with-no-catches [body] - "(All [a] (-> (Lux a) (Lux a)))" - (fn [state] - (let [old-catching (->> state (get$ $host) (get$ $catching))] - (|case (body (update$ $host #(set$ $catching $Nil %) state)) - ($Right state* output) - (return* (update$ $host #(set$ $catching old-catching %) state*) output) - - ($Left msg) - (fail* msg))))) - -(defn default-compiler-info [mode] - (T [;; compiler-name - compiler-name - ;; compiler-version - compiler-version - ;; compiler-mode - mode] - )) - -(defn init-state [mode] - (T [;; "lux;info" - (default-compiler-info mode) - ;; "lux;source" - $Nil - ;; "lux;cursor" - (T ["" -1 -1]) - ;; "lux;modules" - (|table) - ;; "lux;scopes" - $Nil - ;; "lux;types" - +init-bindings+ - ;; "lux;expected" - $None - ;; "lux;seed" - 0 - ;; scope-type-vars - $Nil - ;; "lux;host" - (host nil)] - )) - -(defn save-module [body] - (fn [state] - (|case (body state) - ($Right state* output) - (return* (->> state* - (set$ $scopes (get$ $scopes state)) - (set$ $source (get$ $source state))) - output) - - ($Left msg) - (fail* msg)))) - -(defn in-eval? [mode] - "(-> CompilerMode Bool)" - (|case mode - ($Eval) true - _ false)) - -(defn in-repl? [mode] - "(-> CompilerMode Bool)" - (|case mode - ($REPL) true - _ false)) - -(defn with-eval [body] - (fn [state] - (let [old-mode (->> state (get$ $info) (get$ $compiler-mode))] - (|case (body (update$ $info #(set$ $compiler-mode $Eval %) state)) - ($Right state* output) - (return* (update$ $info #(set$ $compiler-mode old-mode %) state*) output) - - ($Left msg) - (fail* msg))))) - -(def get-eval - (fn [state] - (return* state (->> state (get$ $info) (get$ $compiler-mode) in-eval?)))) - -(def get-mode - (fn [state] - (return* state (->> state (get$ $info) (get$ $compiler-mode))))) - -(def get-writer - (fn [state] - (let [writer* (->> state (get$ $host) (get$ $writer))] - (|case writer* - ($Some datum) - (return* state datum) - - _ - ((fail-with-loc "Writer hasn't been set.") state))))) - -(def get-top-local-env - (fn [state] - (try (let [top (|head (get$ $scopes state))] - (return* state top)) - (catch Throwable _ - ((fail-with-loc "No local environment.") state))))) - -(def gen-id - (fn [state] - (let [seed (get$ $seed state)] - (return* (set$ $seed (inc seed) state) seed)))) - -(defn ->seq [xs] - (|case xs - ($Nil) - (list) - - ($Cons x xs*) - (cons x (->seq xs*)))) - -(defn ->list [seq] - (if (empty? seq) - $Nil - ($Cons (first seq) (->list (rest seq))))) - -(defn |repeat [n x] - (if (> n 0) - ($Cons x (|repeat (dec n) x)) - $Nil)) - -(def get-module-name - (fn [state] - (|case (|reverse (get$ $scopes state)) - ($Nil) - ((fail-with-loc "[Analyser Error] Can't get the module-name without a module.") state) - - ($Cons ?global _) - (return* state (|head (get$ $name ?global)))))) - -(defn find-module [name] - "(-> Text (Lux (Module Compiler)))" - (fn [state] - (if-let [module (|get name (get$ $modules state))] - (return* state module) - ((fail-with-loc (str "[Error] Unknown module: " name)) state)))) - -(def get-current-module - "(Lux (Module Compiler))" - (|do [module-name get-module-name] - (find-module module-name))) - -(defn with-scope [name body] - (fn [state] - (let [old-name (->> state (get$ $scopes) |head (get$ $name)) - output (body (update$ $scopes #($Cons (env name old-name) %) state))] - (|case output - ($Right state* datum) - (return* (update$ $scopes |tail state*) datum) - - _ - output)))) - -(defn run-state [monad state] - (monad state)) - -(defn with-closure [body] - (|do [closure-name (|do [top get-top-local-env] - (return (->> top (get$ $inner-closures) str)))] - (fn [state] - (let [body* (with-scope closure-name body)] - (run-state body* (update$ $scopes #($Cons (update$ $inner-closures inc (|head %)) - (|tail %)) - state)))))) - -(defn without-repl-closure [body] - (|do [_mode get-mode] - (fn [state] - (let [output (body (if (in-repl? _mode) - (update$ $scopes |tail state) - state))] - (|case output - ($Right state* datum) - (return* (set$ $scopes (get$ $scopes state) state*) datum) - - _ - output))))) - -(defn without-repl [body] - (|do [_mode get-mode] - (fn [state] - (let [output (body (if (in-repl? _mode) - (update$ $info #(set$ $compiler-mode $Debug %) state) - state))] - (|case output - ($Right state* datum) - (return* (update$ $info #(set$ $compiler-mode _mode %) state*) datum) - - _ - output))))) - -(def get-scope-name - (fn [state] - (return* state (->> state (get$ $scopes) |head (get$ $name))))) - -(defn with-writer [writer body] - (fn [state] - (let [old-writer (->> state (get$ $host) (get$ $writer)) - output (body (update$ $host #(set$ $writer ($Some writer) %) state))] - (|case output - ($Right ?state ?value) - (return* (update$ $host #(set$ $writer old-writer %) ?state) - ?value) - - _ - output)))) - -(defn with-expected-type [type body] - "(All [a] (-> Type (Lux a)))" - (fn [state] - (let [output (body (set$ $expected ($Some type) state))] - (|case output - ($Right ?state ?value) - (return* (set$ $expected (get$ $expected state) ?state) - ?value) - - _ - output)))) - -(defn with-cursor [^objects cursor body] - "(All [a] (-> Cursor (Lux a)))" - (|let [[_file-name _ _] cursor] - (if (= "" _file-name) - body - (fn [state] - (let [output (body (set$ $cursor cursor state))] - (|case output - ($Right ?state ?value) - (return* (set$ $cursor (get$ $cursor state) ?state) - ?value) - - _ - output)))))) - -(defn with-analysis-meta [^objects cursor type body] - "(All [a] (-> Cursor Type (Lux a)))" - (|let [[_file-name _ _] cursor] - (if (= "" _file-name) - (fn [state] - (let [output (body (->> state - (set$ $expected ($Some type))))] - (|case output - ($Right ?state ?value) - (return* (->> ?state - (set$ $expected (get$ $expected state))) - ?value) - - _ - output))) - (fn [state] - (let [output (body (->> state - (set$ $cursor cursor) - (set$ $expected ($Some type))))] - (|case output - ($Right ?state ?value) - (return* (->> ?state - (set$ $cursor (get$ $cursor state)) - (set$ $expected (get$ $expected state))) - ?value) - - _ - output)))))) - -(def ensure-statement - "(Lux Unit)" - (fn [state] - (|case (get$ $expected state) - ($None) - (return* state unit-tag) - - ($Some _) - ((fail-with-loc "[Error] All statements must be top-level forms.") state)))) - -(def cursor - ;; (Lux Cursor) - (fn [state] - (return* state (get$ $cursor state)))) - -(let [remove-trailing-0s (fn [^String input] - (-> input - (.split "0*$") - (aget 0))) - make-text-start-0 (fn [input] - (loop [accum "" - range 10] - (if (< input range) - (recur (.concat accum "0") - (* 10 range)) - accum))) - count-bin-start-0 (fn [input] - (loop [counter 0 - idx 63] - (if (and (> idx -1) - (not (bit-test input idx))) - (recur (inc counter) - (dec idx)) - counter))) - read-frac-text (fn [^String input] - (let [output* (.split input "0*$")] - (if (= 0 (alength output*)) - (Long/parseUnsignedLong (aget output* 0)) - (Long/parseUnsignedLong input)))) - count-leading-0s (fn [^String input] - (let [parts (.split input "^0*")] - (if (= 2 (alength parts)) - (.length ^String (aget parts 0)) - 0)))] - (defn encode-frac [input] - (if (= 0 input) - ".0" - (let [^String prefix (->> (count-bin-start-0 input) - (bit-shift-left 1) - (make-text-start-0))] - (->> input - (Long/toUnsignedString) - remove-trailing-0s - (.concat prefix))))) - - (defn decode-frac [input] - (if-let [[_ frac-text] (re-find #"^\.(.+)$" input)] - (let [output* (-> frac-text - (string/replace #",_" "") - read-frac-text) - rows-to-move-forward (count-bin-start-0 output*) - scaling-factor (long (Math/pow 10.0 (double (count-leading-0s input))))] - (-> output* - (bit-shift-left rows-to-move-forward) - (/ scaling-factor))) - (assert false (str "Invalid Frac syntax: " input)))) - ) - -(defn show-ast [ast] - (|case ast - [_ ($BoolS ?value)] - (pr-str ?value) - - [_ ($NatS ?value)] - (str "+" (Long/toUnsignedString ?value)) - - [_ ($IntS ?value)] - (pr-str ?value) - - [_ ($FracS ?value)] - (encode-frac ?value) - - [_ ($RealS ?value)] - (pr-str ?value) - - [_ ($CharS ?value)] - (str "#\"" (pr-str ?value) "\"") - - [_ ($TextS ?value)] - (str "\"" ?value "\"") - - [_ ($TagS ?module ?tag)] - (if (.equals "" ?module) - (str "#" ?tag) - (str "#" ?module ";" ?tag)) - - [_ ($SymbolS ?module ?name)] - (if (.equals "" ?module) - ?name - (str ?module ";" ?name)) - - [_ ($TupleS ?elems)] - (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - - [_ ($RecordS ?elems)] - (str "{" (->> ?elems - (|map (fn [elem] - (|let [[k v] elem] - (str (show-ast k) " " (show-ast v))))) - (|interpose " ") (fold str "")) "}") - - [_ ($FormS ?elems)] - (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") - - _ - (assert false (prn-str 'show-ast (adt->text ast))) - )) - -(defn ident->text [ident] - (|let [[?module ?name] ident] - (if (= "" ?module) - ?name - (str ?module ";" ?name)))) - -(defn fold2% [f init xs ys] - (|case [xs ys] - [($Cons x xs*) ($Cons y ys*)] - (|do [init* (f init x y)] - (fold2% f init* xs* ys*)) - - [($Nil) ($Nil)] - (return init) - - [_ _] - (assert false "Lists don't match in size."))) - -(defn map2% [f xs ys] - (|case [xs ys] - [($Cons x xs*) ($Cons y ys*)] - (|do [z (f x y) - zs (map2% f xs* ys*)] - (return ($Cons z zs))) - - [($Nil) ($Nil)] - (return $Nil) - - [_ _] - (assert false "Lists don't match in size."))) - -(defn map2 [f xs ys] - (|case [xs ys] - [($Cons x xs*) ($Cons y ys*)] - ($Cons (f x y) (map2 f xs* ys*)) - - [_ _] - $Nil)) - -(defn fold2 [f init xs ys] - (|case [xs ys] - [($Cons x xs*) ($Cons y ys*)] - (and init - (fold2 f (f init x y) xs* ys*)) - - [($Nil) ($Nil)] - init - - [_ _] - init - ;; (assert false) - )) - -(defn ^:private enumerate* [idx xs] - "(All [a] (-> Int (List a) (List (, Int a))))" - (|case xs - ($Cons x xs*) - ($Cons (T [idx x]) - (enumerate* (inc idx) xs*)) - - ($Nil) - xs - )) - -(defn enumerate [xs] - "(All [a] (-> (List a) (List (, Int a))))" - (enumerate* 0 xs)) - -(def modules - "(Lux (List Text))" - (fn [state] - (return* state (|keys (get$ $modules state))))) - -(defn when% [test body] - "(-> Bool (Lux Unit) (Lux Unit))" - (if test - body - (return unit-tag))) - -(defn |at [idx xs] - "(All [a] (-> Int (List a) (Maybe a)))" - (|case xs - ($Cons x xs*) - (cond (< idx 0) - $None - - (= idx 0) - ($Some x) - - :else ;; > 1 - (|at (dec idx) xs*)) - - ($Nil) - $None - )) - -(defn normalize [ident] - "(-> Ident (Lux Ident))" - (|case ident - ["" name] (|do [module get-module-name] - (return (T [module name]))) - _ (return ident))) - -(defn ident= [x y] - (|let [[xmodule xname] x - [ymodule yname] y] - (and (= xmodule ymodule) - (= xname yname)))) - -(defn |list-put [idx val xs] - (|case xs - ($Nil) - $None - - ($Cons x xs*) - (if (= idx 0) - ($Some ($Cons val xs*)) - (|case (|list-put (dec idx) val xs*) - ($None) $None - ($Some xs**) ($Some ($Cons x xs**))) - ))) - -(do-template [ ] - (do (defn [module] - "(-> Text (Lux Unit))" - (fn [state] - (let [state* (update$ $host (fn [host] - (update$ $module-states - (fn [module-states] - (|put module module-states)) - host)) - state)] - ($Right (T [state* unit-tag]))))) - (defn [module] - "(-> Text (Lux Bool))" - (fn [state] - (if-let [module-state (->> state (get$ $host) (get$ $module-states) (|get module))] - ($Right (T [state (|case module-state - () true - _ false)])) - ($Right (T [state false]))) - ))) - - flag-active-module active-module? $Active - flag-compiled-module compiled-module? $Compiled - flag-cached-module cached-module? $Cached - ) - -(do-template [ ] - (defn [p xs] - "(All [a] (-> (-> a Bool) (List a) Bool))" - (|case xs - ($Nil) - - - ($Cons x xs*) - ( (p x) ( p xs*)))) - - |every? true and - |any? false or) - -(defn m-comp [f g] - "(All [a b c] (-> (-> b (Lux c)) (-> a (Lux b)) (-> a (Lux c))))" - (fn [x] - (|do [y (g x)] - (f y)))) - -(defn with-attempt [m-value on-error] - "(All [a] (-> (Lux a) (-> Text (Lux a)) (Lux a)))" - (fn [state] - (|case (m-value state) - ($Left msg) - ((on-error msg) state) - - output - output))) - -(defn |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*) - output output) - )) - -(def get-type-env - "(Lux TypeEnv)" - (fn [state] - (return* state (->> state (get$ $host) (get$ $type-env))))) - -(defn with-type-env [type-env body] - "(All [a] (-> TypeEnv (Lux a) (Lux a)))" - (fn [state] - (|let [state* (update$ $host #(update$ $type-env (partial |++ type-env) %) - state)] - (|case (body state*) - ($Right [state** output]) - ($Right (T [(update$ $host - #(set$ $type-env - (->> state (get$ $host) (get$ $type-env)) - %) - state**) - output])) - - ($Left msg) - ($Left msg))))) - -(defn |take [n xs] - (|case (T [n xs]) - [0 _] $Nil - [_ ($Nil)] $Nil - [_ ($Cons x xs*)] ($Cons x (|take (dec n) xs*)) - )) - -(defn |drop [n xs] - (|case (T [n xs]) - [0 _] xs - [_ ($Nil)] $Nil - [_ ($Cons x xs*)] (|drop (dec n) xs*) - )) - -(defn |but-last [xs] - (|case xs - ($Nil) - $Nil - - ($Cons x ($Nil)) - $Nil - - ($Cons x xs*) - ($Cons x (|but-last xs*)) - - _ - (assert false (adt->text xs)))) - -(defn |last [xs] - (|case xs - ($Cons x ($Nil)) - x - - ($Cons x xs*) - (|last xs*) - - _ - (assert false (adt->text xs)))) - -(defn |partition [n xs] - (->> xs ->seq (partition-all n) (map ->list) ->list)) - -(defn with-scope-type-var [id body] - (fn [state] - (|case (body (set$ $scope-type-vars - ($Cons id (get$ $scope-type-vars state)) - state)) - ($Right [state* output]) - ($Right (T [(set$ $scope-type-vars - (get$ $scope-type-vars state) - state*) - output])) - - ($Left msg) - ($Left msg)))) - -(defn push-dummy-name [real-name store-name] - (fn [state] - ($Right (T [(update$ $host - #(update$ $dummy-mappings - (partial $Cons (T [real-name store-name])) - %) - state) - nil])))) - -(def pop-dummy-name - (fn [state] - ($Right (T [(update$ $host - #(update$ $dummy-mappings - |tail - %) - state) - nil])))) - -(defn de-alias-class [class-name] - (fn [state] - ($Right (T [state - (|case (|some #(|let [[real-name store-name] %] - (if (= real-name class-name) - ($Some store-name) - $None)) - (->> state (get$ $host) (get$ $dummy-mappings))) - ($Some store-name) - store-name - - _ - class-name)])))) - -(let [!out! *out*] - (defn |log! [& parts] - (binding [*out* !out!] - (do (print (apply str parts)) - (flush))))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj deleted file mode 100644 index d8c5e4571..000000000 --- a/src/lux/compiler.clj +++ /dev/null @@ -1,268 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler - (:refer-clojure :exclude [compile]) - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail* |case]] - [type :as &type] - [reader :as &reader] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [optimizer :as &optimizer] - [host :as &host]) - [lux.host.generics :as &host-generics] - [lux.optimizer :as &o] - [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] - [lambda :as &&lambda] - [module :as &&module] - [io :as &&io] - [parallel :as &¶llel]) - (lux.compiler.cache [type :as &&&type] - [ann :as &&&ann])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) - -;; [Resources] -(def ^:private !source->last-line (atom nil)) - -(defn compile-expression [$begin syntax] - (|let [[[?type [_file-name _line _]] ?form] syntax] - (|do [^MethodVisitor *writer* &/get-writer - :let [debug-label (new Label) - _ (when (not= _line (get @!source->last-line _file-name)) - (doto *writer* - (.visitLabel debug-label) - (.visitLineNumber (int _line) debug-label)) - (swap! !source->last-line assoc _file-name _line))]] - (|case ?form - (&o/$bool ?value) - (&&lux/compile-bool ?value) - - (&o/$nat ?value) - (&&lux/compile-nat ?value) - - (&o/$int ?value) - (&&lux/compile-int ?value) - - (&o/$frac ?value) - (&&lux/compile-frac ?value) - - (&o/$real ?value) - (&&lux/compile-real ?value) - - (&o/$char ?value) - (&&lux/compile-char ?value) - - (&o/$text ?value) - (&&lux/compile-text ?value) - - (&o/$tuple ?elems) - (&&lux/compile-tuple (partial compile-expression $begin) ?elems) - - (&o/$var (&/$Local ?idx)) - (&&lux/compile-local (partial compile-expression $begin) ?idx) - - (&o/$captured ?scope ?captured-id ?source) - (&&lux/compile-captured (partial compile-expression $begin) ?scope ?captured-id ?source) - - (&o/$var (&/$Global ?owner-class ?name)) - (&&lux/compile-global (partial compile-expression $begin) ?owner-class ?name) - - (&o/$apply ?fn ?args) - (&&lux/compile-apply (partial compile-expression $begin) ?fn ?args) - - (&o/$loop _register-offset _inits _body) - (&&lux/compile-loop compile-expression _register-offset _inits _body) - - (&o/$iter _register-offset ?args) - (&&lux/compile-iter (partial compile-expression $begin) $begin _register-offset ?args) - - (&o/$variant ?tag ?tail ?members) - (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members) - - (&o/$case ?value [?pm ?bodies]) - (&&case/compile-case (partial compile-expression $begin) ?value ?pm ?bodies) - - (&o/$let _value _register _body) - (&&lux/compile-let (partial compile-expression $begin) _value _register _body) - - (&o/$record-get _value _path) - (&&lux/compile-record-get (partial compile-expression $begin) _value _path) - - (&o/$if _test _then _else) - (&&lux/compile-if (partial compile-expression $begin) _test _then _else) - - (&o/$function _register-offset ?arity ?scope ?env ?body) - (&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body) - - (&o/$ann ?value-ex ?type-ex) - (compile-expression $begin ?value-ex) - - (&o/$proc [?proc-category ?proc-name] ?args special-args) - (&&host/compile-host (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args) - - _ - (assert false (prn-str 'compile-expression (&/adt->text syntax))) - )) - )) - -(defn init! - "(-> (List Text) Null)" - [resources-dirs target-dir] - (do (reset! &&/!output-dir target-dir) - (&¶llel/setup!) - (reset! !source->last-line {}) - (.mkdirs (java.io.File. target-dir)) - (let [class-loader (ClassLoader/getSystemClassLoader) - addURL (doto (.getDeclaredMethod java.net.URLClassLoader "addURL" (into-array [java.net.URL])) - (.setAccessible true))] - (doseq [resources-dir (&/->seq resources-dirs)] - (.invoke addURL class-loader - (to-array [(->> resources-dir (new java.io.File) .toURI .toURL)])))))) - -(defn eval! [expr] - (&/with-eval - (|do [module &/get-module-name - id &/gen-id - [file-name _ _] &/cursor - :let [class-name (str (&host/->module-class module) "/" id) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - class-name nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) - (doto (.visitEnd))) - (.visitSource file-name nil))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitCode *writer*)] - _ (compile-expression nil expr) - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [bytecode (.toByteArray (doto =class - .visitEnd))] - _ (&&/save-class! (str id) bytecode) - loader &/loader] - (-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id)) - (.getField &/eval-field) - (.get nil) - return)))) - -(def all-compilers - (let [compile-expression* (partial compile-expression nil)] - (&/T [(partial &&lux/compile-def compile-expression) - (partial &&lux/compile-program compile-expression*) - (partial &&host/compile-jvm-class compile-expression*) - &&host/compile-jvm-interface]))) - -(let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) - +datum-sig+ "Ljava/lang/Object;"] - (defn compile-module [source-dirs name] - (let [file-name (str name ".lux")] - (|do [file-content (&&io/read-file source-dirs file-name) - :let [file-hash (hash file-content) - ;; compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs)) - compile-module!! (partial compile-module source-dirs)]] - (if (&&cache/cached? name) - (&&cache/load source-dirs name file-hash compile-module!!) - (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] - (|do [module-exists? (&a-module/exists? name)] - (if module-exists? - (fail "[Compiler Error] Can't redefine a module!") - (|do [_ (&&cache/delete name) - _ (&a-module/create-module name file-hash) - _ (&/flag-active-module name) - :let [module-class-name (str (&host/->module-class name) "/_") - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - module-class-name nil "java/lang/Object" nil) - (-> (.visitField +field-flags+ &/hash-field "I" nil file-hash) - .visitEnd) - (-> (.visitField +field-flags+ &/compiler-field "Ljava/lang/String;" nil &/compiler-version) - .visitEnd) - (.visitSource file-name nil))] - _ (if (= "lux" name) - (|do [_ &&host/compile-Function-class - _ &&host/compile-LuxRT-class] - (return nil)) - (return nil))] - (fn [state] - (|case ((&/with-writer =class - (&/exhaust% compiler-step)) - (&/set$ &/$source (&reader/from name file-content) state)) - (&/$Right ?state _) - (&/run-state (|do [:let [_ (.visitEnd =class)] - module-anns (&a-module/get-anns name) - defs &a-module/defs - imports &a-module/imports - tag-groups &&module/tag-groups - :let [def-entries (->> defs - (&/|map (fn [_def] - (|let [[?name ?alias [?def-type ?def-anns ?def-value]] _def] - (if (= "" ?alias) - (str ?name &&/datum-separator (&&&type/serialize-type ?def-type) &&/datum-separator (&&&ann/serialize-anns ?def-anns)) - (str ?name &&/datum-separator ?alias))))) - (&/|interpose &&/entry-separator) - (&/fold str "")) - import-entries (->> imports - (&/|map (fn [import] - (|let [[_module _hash] import] - (str _module &&/datum-separator _hash)))) - (&/|interpose &&/entry-separator) - (&/fold str "")) - tag-entries (->> tag-groups - (&/|map (fn [group] - (|let [[type tags] group] - (->> tags - (&/|interpose &&/datum-separator) - (&/fold str "") - (str type &&/datum-separator))))) - (&/|interpose &&/entry-separator) - (&/fold str "")) - module-descriptor (->> (&/|list import-entries - tag-entries - (&&&ann/serialize-anns module-anns) - def-entries) - (&/|interpose &&/section-separator) - (&/fold str ""))] - _ (&/flag-compiled-module name) - _ (&&/save-class! &/module-class-name (.toByteArray =class)) - _ (&&/write-module-descriptor! name module-descriptor)] - (return file-hash)) - ?state) - - (&/$Left ?message) - (fail* ?message))))))) - )) - ))) - -(defn compile-program [mode program-module resources-dir source-dirs target-dir] - (do (init! resources-dir target-dir) - (let [m-action (|do [_ (compile-module source-dirs "lux")] - (compile-module source-dirs program-module))] - (|case (m-action (&/init-state mode)) - (&/$Right ?state _) - (do (println "Compilation complete!") - (&&cache/clean ?state)) - - (&/$Left ?message) - (assert false ?message))))) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj deleted file mode 100644 index e57571fef..000000000 --- a/src/lux/compiler/base.clj +++ /dev/null @@ -1,116 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler.base - (:require (clojure [template :refer [do-template]] - [string :as string]) - [clojure.java.io :as io] - [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail*]] - [type :as &type] - [host :as &host]) - (lux.analyser [base :as &a] - [module :as &a-module]) - [lux.host.generics :as &host-generics]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor) - (java.io File - BufferedOutputStream - FileOutputStream) - (java.lang.reflect Field))) - -;; [Constants] -(def !output-dir (atom nil)) - -(def ^:const ^String function-class "lux/Function") -(def ^:const ^String lux-utils-class "lux/LuxRT") -(def ^:const ^String unit-tag-field "unit_tag") - -;; Formats -(def ^:const ^String local-prefix "l") -(def ^:const ^String partial-prefix "p") -(def ^:const ^String closure-prefix "c") -(def ^:const ^String apply-method "apply") -(defn ^String apply-signature [n] - (str "(" (apply str (repeat n "Ljava/lang/Object;")) ")Ljava/lang/Object;")) -(def ^:const num-apply-variants 8) -(def ^:const arity-field "_arity_") -(def ^:const partials-field "_partials_") - -(def ^:const section-separator (->> 29 char str)) -(def ^:const datum-separator (->> 31 char str)) -(def ^:const entry-separator (->> 30 char str)) - -;; [Utils] -(defn ^:private write-file [^String file-name ^bytes data] - (do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name)) - (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))] - (.write stream data)))) - -(defn ^:private write-output [module name data] - (let [module* (&host/->module-class module) - module-dir (str @!output-dir "/" module*)] - (.mkdirs (File. module-dir)) - (write-file (str module-dir "/" name ".class") data))) - -(defn class-exists? [^String module ^String class-name] - "(-> Text Text (IO Bool))" - (|do [_ (return nil) - :let [full-path (str @!output-dir "/" module "/" class-name ".class") - exists? (.exists (File. full-path))]] - (return exists?))) - -;; [Exports] -(defn ^Class load-class! [^ClassLoader loader name] - ;; (prn 'load-class! name) - (.loadClass loader name)) - -(defn save-class! [name bytecode] - (|do [eval? &/get-eval - module &/get-module-name - loader &/loader - !classes &/classes - :let [real-name (str (&host-generics/->class-name module) "." name) - _ (swap! !classes assoc real-name bytecode) - _ (when (not eval?) - (write-output module name bytecode)) - _ (load-class! loader real-name)]] - (return nil))) - -(def ^String lux-module-descriptor-name "lux_module_descriptor") - -(defn write-module-descriptor! [^String name ^String descriptor] - (|do [_ (return nil) - :let [lmd-dir (str @!output-dir "/" name) - _ (.mkdirs (File. lmd-dir)) - _ (write-file (str lmd-dir "/" lux-module-descriptor-name) (.getBytes descriptor java.nio.charset.StandardCharsets/UTF_8))]] - (return nil))) - -(defn read-module-descriptor! [^String name] - (|do [_ (return nil)] - (return (slurp (str @!output-dir "/" name "/" lux-module-descriptor-name) - :encoding "UTF-8")))) - -(do-template [ ] - (do (defn [^MethodVisitor writer] - (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str "(" ")" (&host-generics/->type-signature ))))) - (defn [^MethodVisitor writer] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST ) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (str "()" ))))) - - wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1 - wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1 - wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1 - wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1 - wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2 - wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1 - wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2 - wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1 - ) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj deleted file mode 100644 index 6c44e2a45..000000000 --- a/src/lux/compiler/cache.clj +++ /dev/null @@ -1,188 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler.cache - (:refer-clojure :exclude [load]) - (:require [clojure.string :as string] - [clojure.java.io :as io] - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |case |let]] - [type :as &type] - [host :as &host]) - [lux.host.generics :as &host-generics] - (lux.analyser [base :as &a] - [module :as &a-module] - [meta :as &a-meta]) - (lux.compiler [base :as &&] - [io :as &&io]) - (lux.compiler.cache [type :as &&&type] - [ann :as &&&ann])) - (:import (java.io File - BufferedOutputStream - FileOutputStream) - (java.lang.reflect Field))) - -;; [Utils] -(defn ^:private read-file [^File file] - "(-> File (Array Byte))" - (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] - "(-> File (,))" - (doseq [^File f (seq (.listFiles file)) - :when (not (.isDirectory f))] - (.delete f))) - -(defn ^:private get-field [^String field-name ^Class class] - "(-> Text Class Object)" - (-> class ^Field (.getField field-name) (.get nil))) - -;; [Resources] -(def module-class (str &/module-class-name ".class")) - -(defn cached? [module] - "(-> Text Bool)" - (.exists (new File (str @&&/!output-dir "/" (&host/->module-class module) "/" module-class))) - ;; false - ) - -(defn delete [module] - "(-> Text (Lux Null))" - (fn [state] - (do (clean-file (new File (str @&&/!output-dir "/" (&host/->module-class module)))) - (return* state nil)))) - -(defn ^:private module-dirs - "(-> File (clojure.Seq File))" - [^File module] - (->> module - .listFiles - (filter #(.isDirectory %)) - (map module-dirs) - (apply concat) - (list* module))) - -(defn clean [state] - "(-> Compiler Null)" - (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) - output-dir-prefix (str (.getAbsolutePath (new File @&&/!output-dir)) "/") - outdated? #(->> % (contains? needed-modules) not) - outdated-modules (->> (new File @&&/!output-dir) - .listFiles (filter #(.isDirectory %)) - (map module-dirs) doall (apply concat) - (map #(-> ^File % .getAbsolutePath (string/replace output-dir-prefix ""))) - (filter outdated?))] - (doseq [^String f outdated-modules] - (clean-file (new File (str output-dir-prefix f)))) - nil)) - -(defn ^:private install-all-classes-in-module [!classes module* ^String module-path] - (doseq [^File file (seq (.listFiles (File. module-path))) - :when (not (.isDirectory file)) - :let [file-name (.getName file)] - :when (not= module-class file-name)] - (let [real-name (second (re-find #"^(.*)\.class$" file-name)) - bytecode (read-file file)] - (swap! !classes assoc (str module* "." real-name) bytecode)))) - -(defn ^:private assume-async-result - "(-> (Error Compiler) (Lux Null))" - [result] - (fn [_] - (|case result - (&/$Left error) - (&/$Left error) - - (&/$Right compiler) - (return* compiler nil)))) - -(defn load [source-dirs module module-hash compile-module] - "(-> (List Text) Text Int (-> Text (Lux (,))) (Lux Bool))" - (|do [already-loaded? (&a-module/exists? module)] - (if already-loaded? - (return module-hash) - (|let [redo-cache (|do [_ (delete module) - ;; async (compile-module module) - ] - ;; (assume-async-result @async) - (compile-module module))] - (if (cached? module) - (|do [loader &/loader - !classes &/classes - :let [module* (&host-generics/->class-name module) - module-path (str @&&/!output-dir "/" module) - class-name (str module* "._") - old-classes @!classes - ^Class module-class (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) - (&&/load-class! loader class-name)) - _ (install-all-classes-in-module !classes module* module-path)]] - (if (and (= module-hash (get-field &/hash-field module-class)) - (= &/compiler-version (get-field &/compiler-field module-class))) - (|do [^String descriptor (&&/read-module-descriptor! module) - :let [sections (.split descriptor &&/section-separator) - [^String imports-section ^String tags-section module-anns-section ^String defs-section] sections - imports (vec (.split imports-section &&/entry-separator))] - loads (&/map% (fn [^String _import] - (let [[_module _hash] (.split _import &&/datum-separator 2)] - (|do [file-content (&&io/read-file source-dirs (str _module ".lux")) - :let [file-hash (hash file-content) - __hash (Integer/parseInt _hash)] - _ (load source-dirs _module file-hash compile-module) - cached? (&/cached-module? _module) - :let [consistent-cache? (= file-hash __hash)]] - (return (and cached? - consistent-cache?))))) - (if (= [""] imports) - &/$Nil - (&/->list imports)))] - (if (->> loads &/->seq (every? true?)) - (|do [:let [tag-groups (if (= "" tags-section) - &/$Nil - (-> tags-section - (.split &&/entry-separator) - seq - (->> (map (fn [^String _group] - (let [[_type & _tags] (.split _group &&/datum-separator)] - (&/T [_type (->> _tags seq &/->list)]))))) - &/->list))] - _ (&a-module/create-module module module-hash) - _ (&a-module/set-anns (&&&ann/deserialize-anns module-anns-section) module) - _ (&/flag-cached-module module) - _ (&a-module/set-imports imports) - :let [desc-defs (vec (.split defs-section &&/entry-separator))] - _ (&/map% (fn [^String _def-entry] - (let [parts (.split _def-entry &&/datum-separator)] - (case (alength parts) - 2 (let [[_name _alias] parts - [_ __module __name] (re-find #"^(.*);(.*)$" _alias) - def-class (&&/load-class! loader (str (&host-generics/->class-name __module) "." (&host/def-name __name))) - def-type (&a-module/def-type __module __name) - def-anns (&/|list (&/T [&a-meta/alias-tag (&/$IdentM (&/T [__module __name]))])) - def-value (get-field &/value-field def-class)] - (&a-module/define module _name def-type def-anns def-value)) - 3 (let [[_name _type _anns] parts - def-class (&&/load-class! loader (str module* "." (&host/def-name _name))) - [def-anns _] (&&&ann/deserialize-anns _anns) - [def-type _] (&&&type/deserialize-type _type) - def-value (get-field &/value-field def-class)] - (&a-module/define module _name def-type def-anns def-value))))) - (if (= [""] desc-defs) - &/$Nil - (&/->list desc-defs))) - _ (&/map% (fn [group] - (|let [[_type _tags] group] - (|do [[was-exported? =type] (&a-module/type-def module _type)] - (&a-module/declare-tags module _tags was-exported? =type)))) - tag-groups)] - (return module-hash)) - redo-cache)) - (do (reset! !classes old-classes) - redo-cache))) - redo-cache))))) diff --git a/src/lux/compiler/cache/ann.clj b/src/lux/compiler/cache/ann.clj deleted file mode 100644 index d50c02465..000000000 --- a/src/lux/compiler/cache/ann.clj +++ /dev/null @@ -1,159 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler.cache.ann - (:require (clojure [template :refer [do-template]] - [string :as string]) - [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail* |case]]))) - -(def ^:private stop (->> 7 char str)) -(def ^:private cons-signal (->> 5 char str)) -(def ^:private nil-signal (->> 6 char str)) -(def ^:private ident-separator ";") - -(defn ^:private serialize-seq [serialize-ann params] - (str (&/fold (fn [so-far param] - (str so-far cons-signal (serialize-ann param))) - "" - params) - nil-signal)) - -(defn ^:private serialize-text [value] - (str "T" value stop)) - -(defn ^:private serialize-ident [ident] - (|let [[module name] ident] - (str "@" module ident-separator name stop))) - -(defn serialize-ann - "(-> Ann-Value Text)" - [ann] - (|case ann - (&/$BoolM value) - (str "B" value stop) - - (&/$NatM value) - (str "N" value stop) - - (&/$IntM value) - (str "I" value stop) - - (&/$FracM value) - (str "F" value stop) - - (&/$RealM value) - (str "R" value stop) - - (&/$CharM value) - (str "C" value stop) - - (&/$TextM value) - (serialize-text value) - - (&/$IdentM ident) - (serialize-ident ident) - - (&/$ListM elems) - (str "L" (serialize-seq serialize-ann elems)) - - (&/$DictM kvs) - (str "D" (serialize-seq (fn [kv] - (|let [[k v] kv] - (str (serialize-text k) - (serialize-ann v)))) - kvs)) - - _ - (assert false) - )) - -(defn serialize-anns - "(-> Anns Text)" - [anns] - (serialize-seq (fn [kv] - (|let [[k v] kv] - (str (serialize-ident k) - (serialize-ann v)))) - anns)) - -(declare deserialize-ann) - -(do-template [ ] - (defn [^String input] - (when (.startsWith input ) - (let [[value* ^String input*] (.split (.substring input 1) stop 2)] - [( ( value*)) input*]))) - - ^:private deserialize-bool "B" &/$BoolM Boolean/parseBoolean - ^:private deserialize-nat "N" &/$NatM Long/parseLong - ^:private deserialize-int "I" &/$IntM Long/parseLong - ^:private deserialize-frac "F" &/$FracM Long/parseLong - ^:private deserialize-real "R" &/$RealM Double/parseDouble - ^:private deserialize-char "C" &/$CharM (fn [^String input] (.charAt input 0)) - ^:private deserialize-text "T" &/$TextM identity - ) - -(defn ^:private deserialize-ident* [^String input] - (when (.startsWith input "@") - (let [[ident* ^String input*] (.split (.substring input 1) stop 2) - [_module _name] (.split ident* ident-separator 2)] - [(&/T [_module _name]) input*]))) - -(defn ^:private deserialize-ident [^String input] - (when (.startsWith input "@") - (let [[ident* ^String input*] (.split (.substring input 1) stop 2) - [_module _name] (.split ident* ident-separator 2)] - [(&/$IdentM (&/T [_module _name])) input*]))) - -(defn ^:private deserialize-seq [deserializer input] - (cond (.startsWith input nil-signal) - [&/$Nil (.substring input 1)] - - (.startsWith input cons-signal) - (when-let [[head ^String input*] (deserializer (.substring input 1))] - (when-let [[tail ^String input*] (deserialize-seq deserializer input*)] - [(&/$Cons head tail) input*])) - )) - -(do-template [ ] - (defn [input] - (when-let [[key input*] ( input)] - (when-let [[ann input*] (deserialize-ann input*)] - [(&/T [key ann]) input*]))) - - ^:private deserialize-kv deserialize-text - ^:private deserialize-ann-entry deserialize-ident* - ) - -(do-template [ ] - (defn [^String input] - (when (.startsWith input ) - (when-let [[elems ^String input*] (deserialize-seq - (.substring input 1))] - [( elems) input*]))) - - ^:private deserialize-list "L" &/$ListM deserialize-ann - ^:private deserialize-dict "D" &/$DictM deserialize-kv - ) - -(defn ^:private deserialize-ann - "(-> Text Anns)" - [input] - (or (deserialize-bool input) - (deserialize-nat input) - (deserialize-int input) - (deserialize-frac input) - (deserialize-real input) - (deserialize-char input) - (deserialize-text input) - (deserialize-ident input) - (deserialize-list input) - (deserialize-dict input) - (assert false "[Cache error] Can't deserialize annocation."))) - -(defn deserialize-anns [^String input] - (deserialize-seq deserialize-ann-entry input)) diff --git a/src/lux/compiler/cache/type.clj b/src/lux/compiler/cache/type.clj deleted file mode 100644 index 80d3a93d6..000000000 --- a/src/lux/compiler/cache/type.clj +++ /dev/null @@ -1,164 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler.cache.type - (:require (clojure [template :refer [do-template]] - [string :as string]) - [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail* |case]] - [type :as &type]))) - -(def ^:private stop (->> 7 char str)) -(def ^:private cons-signal (->> 5 char str)) -(def ^:private nil-signal (->> 6 char str)) -(def ^:private ident-separator ";") - -(defn ^:private serialize-list [serialize-type params] - (str (&/fold (fn [so-far param] - (str so-far cons-signal (serialize-type param))) - "" - params) - nil-signal)) - -(defn serialize-type - "(-> Type Text)" - [type] - (if (clojure.lang.Util/identical &type/Type type) - "T" - (|case type - (&/$HostT name params) - (str "^" name stop (serialize-list serialize-type params)) - - (&/$VoidT) - "0" - - (&/$UnitT) - "1" - - (&/$ProdT left right) - (str "*" (serialize-type left) (serialize-type right)) - - (&/$SumT left right) - (str "+" (serialize-type left) (serialize-type right)) - - (&/$LambdaT left right) - (str ">" (serialize-type left) (serialize-type right)) - - (&/$UnivQ env body) - (str "U" (serialize-list serialize-type env) (serialize-type body)) - - (&/$ExQ env body) - (str "E" (serialize-list serialize-type env) (serialize-type body)) - - (&/$BoundT idx) - (str "$" idx stop) - - (&/$ExT idx) - (str "!" idx stop) - - (&/$VarT idx) - (str "?" idx stop) - - (&/$AppT left right) - (str "%" (serialize-type left) (serialize-type right)) - - (&/$NamedT [module name] type*) - (str "@" module ident-separator name stop (serialize-type type*)) - - _ - (assert false (prn 'serialize-type (&type/show-type type))) - ))) - -(declare deserialize-type) - -(defn ^:private deserialize-list [input] - (cond (.startsWith input nil-signal) - [&/$Nil (.substring input 1)] - - (.startsWith input cons-signal) - (when-let [[head ^String input*] (deserialize-type (.substring input 1))] - (when-let [[tail ^String input*] (deserialize-list input*)] - [(&/$Cons head tail) input*])) - )) - -(do-template [ ] - (defn [^String input] - (when (.startsWith input ) - [ (.substring input 1)] - )) - - ^:private deserialize-void "0" &/$VoidT - ^:private deserialize-unit "1" &/$UnitT - ^:private deserialize-type* "T" &type/Type - ) - -(do-template [ ] - (defn [^String input] - (when (.startsWith input ) - (when-let [[left ^String input*] (deserialize-type (.substring input 1))] - (when-let [[right ^String input*] (deserialize-type input*)] - [( left right) input*])) - )) - - ^:private deserialize-sum "+" &/$SumT - ^:private deserialize-prod "*" &/$ProdT - ^:private deserialize-lambda ">" &/$LambdaT - ^:private deserialize-app "%" &/$AppT - ) - -(do-template [ ] - (defn [^String input] - (when (.startsWith input ) - (let [[idx ^String input*] (.split (.substring input 1) stop 2)] - [( (Long/parseLong idx)) input*]))) - - ^:private deserialize-bound "$" &/$BoundT - ^:private deserialize-ex "!" &/$ExT - ^:private deserialize-var "?" &/$VarT - ) - -(defn ^:private deserialize-named [^String input] - (when (.startsWith input "@") - (let [[^String module+name ^String input*] (.split (.substring input 1) stop 2) - [module name] (.split module+name ident-separator 2)] - (when-let [[type* ^String input*] (deserialize-type input*)] - [(&/$NamedT (&/T [module name]) type*) input*])))) - -(do-template [ ] - (defn [^String input] - (when (.startsWith input ) - (when-let [[env ^String input*] (deserialize-list (.substring input 1))] - (when-let [[body ^String input*] (deserialize-type input*)] - [( env body) input*])))) - - ^:private deserialize-univq "U" &/$UnivQ - ^:private deserialize-exq "E" &/$ExQ - ) - -(defn ^:private deserialize-host [^String input] - (when (.startsWith input "^") - (let [[name ^String input*] (.split (.substring input 1) stop 2)] - (when-let [[params ^String input*] (deserialize-list input*)] - [(&/$HostT name params) input*])))) - -(defn deserialize-type - "(-> Text Type)" - [input] - (or (deserialize-type* input) - (deserialize-void input) - (deserialize-unit input) - (deserialize-sum input) - (deserialize-prod input) - (deserialize-lambda input) - (deserialize-app input) - (deserialize-bound input) - (deserialize-ex input) - (deserialize-var input) - (deserialize-named input) - (deserialize-univq input) - (deserialize-exq input) - (deserialize-host input) - (assert false (str "[Cache error] Can't deserialize type. --- " input)))) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj deleted file mode 100644 index afdcd3eed..000000000 --- a/src/lux/compiler/case.clj +++ /dev/null @@ -1,219 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler.case - (:require (clojure [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [host :as &host] - [optimizer :as &o]) - [lux.analyser.case :as &a-case] - [lux.compiler.base :as &&]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) - -;; [Utils] -(defn ^:private pop-alt-stack [^MethodVisitor writer stack-depth] - (cond (= 0 stack-depth) - writer - - (= 1 stack-depth) - (doto writer - (.visitInsn Opcodes/POP)) - - (= 2 stack-depth) - (doto writer - (.visitInsn Opcodes/POP2)) - - :else ;; > 2 - (doto writer - (.visitInsn Opcodes/POP2) - (pop-alt-stack (- stack-depth 2))))) - -(defn ^:private stack-peek [^MethodVisitor writer] - (doto writer - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;"))) - -(defn ^:private compile-pattern* [^MethodVisitor writer bodies stack-depth $else pm] - "(-> MethodVisitor Case-Pattern (List Label) Int Label MethodVisitor)" - (|case pm - (&o/$ExecPM _body-idx) - (|case (&/|at _body-idx bodies) - (&/$Some $body) - (doto writer - (pop-alt-stack stack-depth) - (.visitJumpInsn Opcodes/GOTO $body)) - - (&/$None) - (assert false)) - - (&o/$PopPM) - (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;")) - - (&o/$BindPM _var-id) - (doto writer - stack-peek - (.visitVarInsn Opcodes/ASTORE _var-id) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;")) - - (&o/$BoolPM _value) - (doto writer - stack-peek - &&/unwrap-boolean - (.visitJumpInsn (if _value Opcodes/IFEQ Opcodes/IFNE) $else)) - - (&o/$NatPM _value) - (doto writer - stack-peek - &&/unwrap-long - (.visitLdcInsn (long _value)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFNE $else)) - - (&o/$IntPM _value) - (doto writer - stack-peek - &&/unwrap-long - (.visitLdcInsn (long _value)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFNE $else)) - - (&o/$FracPM _value) - (doto writer - stack-peek - &&/unwrap-long - (.visitLdcInsn (long _value)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFNE $else)) - - (&o/$RealPM _value) - (doto writer - stack-peek - &&/unwrap-double - (.visitLdcInsn (double _value)) - (.visitInsn Opcodes/DCMPL) - (.visitJumpInsn Opcodes/IFNE $else)) - - (&o/$CharPM _value) - (doto writer - stack-peek - &&/unwrap-char - (.visitLdcInsn _value) - (.visitJumpInsn Opcodes/IF_ICMPNE $else)) - - (&o/$TextPM _value) - (doto writer - stack-peek - (.visitLdcInsn _value) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (.visitJumpInsn Opcodes/IFEQ $else)) - - (&o/$TuplePM _idx+) - (|let [[_idx is-tail?] (|case _idx+ - (&/$Left _idx) - (&/T [_idx false]) - - (&/$Right _idx) - (&/T [_idx true]))] - (if (= 0 _idx) - (doto writer - stack-peek - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) - (doto writer - stack-peek - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int _idx)) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" (if is-tail? "product_getRight" "product_getLeft") "([Ljava/lang/Object;I)Ljava/lang/Object;") - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - ))) - - (&o/$VariantPM _idx+) - (|let [$success (new Label) - $fail (new Label) - [_idx is-last] (|case _idx+ - (&/$Left _idx) - (&/T [_idx false]) - - (&/$Right _idx) - (&/T [_idx true])) - _ (doto writer - stack-peek - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int _idx))) - _ (if is-last - (.visitLdcInsn writer "") - (.visitInsn writer Opcodes/ACONST_NULL))] - (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitJumpInsn Opcodes/IFNULL $fail) - (.visitJumpInsn Opcodes/GOTO $success) - (.visitLabel $fail) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else) - (.visitLabel $success) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))) - - (&o/$SeqPM _left-pm _right-pm) - (doto writer - (compile-pattern* bodies stack-depth $else _left-pm) - (compile-pattern* bodies stack-depth $else _right-pm)) - - (&o/$AltPM _left-pm _right-pm) - (|let [$alt-else (new Label)] - (doto writer - (.visitInsn Opcodes/DUP) - (compile-pattern* bodies (inc stack-depth) $alt-else _left-pm) - (.visitLabel $alt-else) - (.visitInsn Opcodes/POP) - (compile-pattern* bodies stack-depth $else _right-pm))) - )) - -(defn ^:private compile-pattern [^MethodVisitor writer bodies pm $end] - (|let [$else (new Label)] - (doto writer - (compile-pattern* bodies 1 $else pm) - (.visitLabel $else) - (.visitInsn Opcodes/POP) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_fail" "()V") - (.visitInsn Opcodes/ACONST_NULL) - (.visitJumpInsn Opcodes/GOTO $end)))) - -(defn ^:private compile-bodies [^MethodVisitor writer compile bodies-labels ?bodies $end] - (&/map% (fn [label+body] - (|let [[_label _body] label+body] - (|do [:let [_ (.visitLabel writer _label)] - _ (compile _body) - :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] - (return nil)))) - (&/zip2 bodies-labels ?bodies))) - -;; [Resources] -(defn compile-case [compile ?value ?pm ?bodies] - (|do [^MethodVisitor *writer* &/get-writer - :let [$end (new Label) - bodies-labels (&/|map (fn [_] (new Label)) ?bodies)] - _ (compile ?value) - :let [_ (doto *writer* - (.visitInsn Opcodes/ACONST_NULL) - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) - _ (compile-pattern *writer* bodies-labels ?pm $end)] - _ (compile-bodies *writer* compile bodies-labels ?bodies $end) - :let [_ (.visitLabel *writer* $end)]] - (return nil))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj deleted file mode 100644 index 9f6d077be..000000000 --- a/src/lux/compiler/host.clj +++ /dev/null @@ -1,2514 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler.host - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [optimizer :as &o] - [host :as &host]) - [lux.type.host :as &host-type] - [lux.host.generics :as &host-generics] - [lux.analyser.base :as &a] - [lux.compiler.base :as &&]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor - AnnotationVisitor))) - -;; [Utils] -(def init-method "") - -(let [class+method+sig {"boolean" [(&host-generics/->bytecode-class-name "java.lang.Boolean") "booleanValue" "()Z"] - "byte" [(&host-generics/->bytecode-class-name "java.lang.Byte") "byteValue" "()B"] - "short" [(&host-generics/->bytecode-class-name "java.lang.Short") "shortValue" "()S"] - "int" [(&host-generics/->bytecode-class-name "java.lang.Integer") "intValue" "()I"] - "long" [(&host-generics/->bytecode-class-name "java.lang.Long") "longValue" "()J"] - "float" [(&host-generics/->bytecode-class-name "java.lang.Float") "floatValue" "()F"] - "double" [(&host-generics/->bytecode-class-name "java.lang.Double") "doubleValue" "()D"] - "char" [(&host-generics/->bytecode-class-name "java.lang.Character") "charValue" "()C"]}] - (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name] - (if-let [[class method sig] (get class+method+sig class-name)] - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST class) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig)) - (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name))))) - -(let [boolean-class "java.lang.Boolean" - byte-class "java.lang.Byte" - short-class "java.lang.Short" - int-class "java.lang.Integer" - long-class "java.lang.Long" - float-class "java.lang.Float" - double-class "java.lang.Double" - char-class "java.lang.Character"] - (defn prepare-return! [^MethodVisitor *writer* *type*] - (|case *type* - (&/$UnitT) - (.visitLdcInsn *writer* &/unit-tag) - - (&/$HostT "boolean" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class))) - - (&/$HostT "byte" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class))) - - (&/$HostT "short" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class))) - - (&/$HostT "int" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class))) - - (&/$HostT "long" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class))) - - (&/$HostT "float" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class))) - - (&/$HostT "double" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class))) - - (&/$HostT "char" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class))) - - (&/$HostT _ _) - nil - - (&/$NamedT ?name ?type) - (prepare-return! *writer* ?type) - - (&/$ExT _) - nil - - _ - (assert false (str 'prepare-return! " " (&type/show-type *type*)))) - *writer*)) - -;; [Resources] -(defn ^:private compile-annotation [writer ann] - (doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->type-signature (:name ann)) true) - (-> (.visit param-name param-value) - (->> (|let [[param-name param-value] param]) - (doseq [param (&/->seq (:params ann))]))) - (.visitEnd)) - nil) - -(defn ^:private compile-field [^ClassWriter writer field] - (|case field - (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) - (|let [=field (.visitField writer - (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) - ?name - (&host-generics/gclass->simple-signature ?gclass) - (&host-generics/gclass->signature ?gclass) nil)] - (do (&/|map (partial compile-annotation =field) ?anns) - (.visitEnd =field) - nil)) - - (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type) - (|let [=field (.visitField writer - (+ (&host/privacy-modifier->flag =privacy-modifier) - (&host/state-modifier->flag =state-modifier)) - =name - (&host-generics/gclass->simple-signature =type) - (&host-generics/gclass->signature =type) nil)] - (do (&/|map (partial compile-annotation =field) =anns) - (.visitEnd =field) - nil)) - )) - -(defn ^:private compile-method-return [^MethodVisitor writer output] - (|case output - (&/$GenericClass "void" (&/$Nil)) - (.visitInsn writer Opcodes/RETURN) - - (&/$GenericClass "boolean" (&/$Nil)) - (doto writer - &&/unwrap-boolean - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "byte" (&/$Nil)) - (doto writer - &&/unwrap-byte - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "short" (&/$Nil)) - (doto writer - &&/unwrap-short - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "int" (&/$Nil)) - (doto writer - &&/unwrap-int - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "long" (&/$Nil)) - (doto writer - &&/unwrap-long - (.visitInsn Opcodes/LRETURN)) - - (&/$GenericClass "float" (&/$Nil)) - (doto writer - &&/unwrap-float - (.visitInsn Opcodes/FRETURN)) - - (&/$GenericClass "double" (&/$Nil)) - (doto writer - &&/unwrap-double - (.visitInsn Opcodes/DRETURN)) - - (&/$GenericClass "char" (&/$Nil)) - (doto writer - &&/unwrap-char - (.visitInsn Opcodes/IRETURN)) - - _ - (.visitInsn writer Opcodes/ARETURN))) - -(defn ^:private prepare-method-input [idx input ^MethodVisitor method-visitor] - "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))" - (|case input - [_ (&/$GenericClass name params)] - (case name - "boolean" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-boolean - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))]))) - "byte" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-byte - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))]))) - "short" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-short - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))]))) - "int" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-int - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))]))) - "long" (do (doto method-visitor - (.visitVarInsn Opcodes/LLOAD idx) - &&/wrap-long - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)]))) - "float" (do (doto method-visitor - (.visitVarInsn Opcodes/FLOAD idx) - &&/wrap-float - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))]))) - "double" (do (doto method-visitor - (.visitVarInsn Opcodes/DLOAD idx) - &&/wrap-double - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)]))) - "char" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-char - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))]))) - ;; else - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))]))) - - [_ gclass] - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))])) - )) - -(defn ^:private prepare-method-inputs [idx inputs method-visitor] - "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))" - (|case inputs - (&/$Nil) - (return &/$Nil) - - (&/$Cons input inputs*) - (|do [[_ outputs*] (&/fold% (fn [idx+outputs input] - (|do [:let [[_idx _outputs] idx+outputs] - [idx* output] (prepare-method-input _idx input method-visitor)] - (return (&/T [idx* (&/$Cons output _outputs)])))) - (&/T [idx &/$Nil]) - inputs)] - (return (&/list-join (&/|reverse outputs*)))) - )) - -(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def] - (|case method-def - (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) - (|let [?output (&/$GenericClass "void" (&/|list)) - =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ (&host/privacy-modifier->flag ?privacy-modifier) - (if ?strict Opcodes/ACC_STRICT 0)) - init-method - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [[super-class-name super-class-params] ?super-class - init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str "")) - init-sig (str "(" init-types ")" "V") - _ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 1 ?inputs =method) - :let [_ (.visitVarInsn =method Opcodes/ALOAD 0)] - _ (->> ?ctor-args (&/|map &/|second) (&/map% compile)) - :let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)] - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$VirtualMethodAnalysis ?name ?privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ (&host/privacy-modifier->flag ?privacy-modifier) - (if =final? Opcodes/ACC_FINAL 0) - (if ?strict Opcodes/ACC_STRICT 0)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 1 ?inputs =method) - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$OverridenMethodAnalysis ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ Opcodes/ACC_PUBLIC - (if ?strict Opcodes/ACC_STRICT 0)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 1 ?inputs =method) - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$StaticMethodAnalysis ?name ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ (&host/privacy-modifier->flag ?privacy-modifier) - (if ?strict Opcodes/ACC_STRICT 0) - Opcodes/ACC_STATIC) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 0 ?inputs =method) - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$AbstractMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ Opcodes/ACC_ABSTRACT - (&host/privacy-modifier->flag ?privacy-modifier)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitEnd =method)]] - (return nil)))) - - (&/$NativeMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE - (&host/privacy-modifier->flag ?privacy-modifier)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitEnd =method)]] - (return nil)))) - )) - -(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl] - (|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl) - =method (.visitMethod class-writer - (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - _ (&/|map (partial compile-annotation =method) =anns) - _ (.visitEnd =method)] - nil)) - -(defn ^:private prepare-ctor-arg [^MethodVisitor writer type] - (case type - "boolean" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Boolean")) - &&/unwrap-boolean) - "byte" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Byte")) - &&/unwrap-byte) - "short" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Short")) - &&/unwrap-short) - "int" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Integer")) - &&/unwrap-int) - "long" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Long")) - &&/unwrap-long) - "float" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Float")) - &&/unwrap-float) - "double" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Double")) - &&/unwrap-double) - "char" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Character")) - &&/unwrap-char) - ;; else - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type))))) - -(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object") - -return "V"] - (defn ^:private anon-class--signature [env] - (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" - -return)) - - (defn ^:private add-anon-class- [^ClassWriter class-writer compile class-name super-class env ctor-args] - (|let [[super-class-name super-class-params] super-class - init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))] - (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class--signature env) nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (doto =method - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0))] - _ (&/map% (fn [type+term] - (|let [[type term] type+term] - (|do [_ (compile term) - :let [_ (prepare-ctor-arg =method type)]] - (return nil)))) - ctor-args) - :let [_ (doto =method - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method (str "(" init-types ")" -return)) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) - (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (|case ?name+?captured - [?name [_ (&o/$captured _ ?captured-id ?source)]]) - (doseq [?name+?captured (&/->seq env)]))) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) - ) - -(defn ^:private constant-inits [fields] - "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))" - (&/fold &/|++ - &/$Nil - (&/|map (fn [field] - (|case field - (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) - (&/|list (&/T [?name ?gclass ?value])) - - (&/$VariableFieldSyntax _) - (&/|list) - )) - fields))) - -(declare compile-jvm-putstatic) -(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?inheritance-modifier ?anns ?fields ?methods env ??ctor-args] - (|do [module &/get-module-name - [file-name line column] &/cursor - :let [[?name ?params] class-decl - class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons ?super-class ?interfaces)) - full-name (str module "/" ?name) - super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class)) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER - (&host/inheritance-modifier->flag ?inheritance-modifier)) - full-name (if (= "" class-signature) nil class-signature) super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) - (.visitSource file-name nil)) - _ (&/|map (partial compile-annotation =class) ?anns) - _ (&/|map (partial compile-field =class) - ?fields)] - _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods) - _ (|case ??ctor-args - (&/$Some ctor-args) - (add-anon-class- =class compile full-name ?super-class env ctor-args) - - _ - (return nil)) - _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (doto =method - (.visitCode))] - _ (&/map% (fn [ftriple] - (|let [[fname fgclass fvalue] ftriple] - (compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass)))) - (constant-inits ?fields)) - :let [_ (doto =method - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))] - (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) - -(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods] - (|do [:let [[interface-name interface-vars] interface-decl] - module &/get-module-name - [file-name _ _] &/cursor - :let [interface-signature (&host-generics/gclass-decl->signature interface-decl ?supers) - =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE) - (str module "/" interface-name) - (if (= "" interface-signature) nil interface-signature) - "java/lang/Object" - (->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) - (.visitSource file-name nil)) - _ (&/|map (partial compile-annotation =interface) ?anns) - _ (do (&/|map (partial compile-method-decl =interface) ?methods) - (.visitEnd =interface))]] - (&&/save-class! interface-name (.toByteArray =interface)))) - -(def compile-Function-class - (|do [_ (return nil) - :let [super-class "java/lang/Object" - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER - Opcodes/ACC_ABSTRACT - ;; Opcodes/ACC_INTERFACE - ) - &&/function-class nil super-class (into-array String [])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil) - (doto (.visitEnd)))) - =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (dotimes [arity* &&/num-apply-variants] - (let [arity (inc arity*)] - (if (= 1 arity) - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil) - (.visitEnd)) - (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil) - (.visitCode) - (-> (.visitVarInsn Opcodes/ALOAD idx) - (->> (dotimes [idx arity]))) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity))) - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitVarInsn Opcodes/ALOAD arity) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))))]] - (&&/save-class! (second (string/split &&/function-class #"/")) - (.toByteArray (doto =class .visitEnd))))) - -(defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class] - (|let [_ (let [$begin (new Label) - $not-rec (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index - (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem - (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem - (.visitJumpInsn Opcodes/IF_ICMPGT $not-rec) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/SWAP) ;; index-last-elem, tuple-size - (.visitInsn Opcodes/ISUB) ;; sub-index - (.visitVarInsn Opcodes/ALOAD 0) ;; sub-index, tuple - (.visitInsn Opcodes/DUP) ;; sub-index, tuple, tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; sub-index, tuple, tuple-size - (.visitLdcInsn (int 1)) ;; sub-index, tuple, tuple-size, offset-last-elem - (.visitInsn Opcodes/ISUB) ;; sub-index, tuple, index-last-elem - (.visitInsn Opcodes/AALOAD) ;; sub-index, sub-tuple - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitVarInsn Opcodes/ASTORE 0) ;; sub-index - (.visitVarInsn Opcodes/ISTORE 1) ;; - (.visitJumpInsn Opcodes/GOTO $begin) - (.visitLabel $not-rec) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/POP2) ;; - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index - (.visitInsn Opcodes/AALOAD) ;; elem - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$begin (new Label) - $is-last (new Label) - $must-copy (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index - (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem - (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem - (.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem - (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;; - ;; Must recurse - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitInsn Opcodes/DUP) ;; tuple, tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size - (.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem - (.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem - (.visitInsn Opcodes/AALOAD) ;; tuple-tail - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size - (.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1 - (.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size* - (.visitInsn Opcodes/ISUB) ;; tuple-tail, index* - (.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail - (.visitVarInsn Opcodes/ASTORE 0) ;; - (.visitJumpInsn Opcodes/GOTO $begin) - (.visitLabel $must-copy) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARRAYLENGTH) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitLabel $is-last) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/POP2) ;; - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index - (.visitInsn Opcodes/AALOAD) ;; elem - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$begin (new Label) - $just-return (new Label) - $then (new Label) - $further (new Label) - $not-right (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - (.visitVarInsn Opcodes/ILOAD 1) ;; tag - (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum - (.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx - (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag' - &&/unwrap-int ;; tag, sum-tag - (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag - (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag - (.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag - (.visitInsn Opcodes/POP2) - (.visitInsn Opcodes/ACONST_NULL) - (.visitInsn Opcodes/ARETURN) - (.visitLabel $then) ;; tag, sum-tag - (.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last? - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last? - (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return) - (.visitJumpInsn Opcodes/GOTO $further) - (.visitLabel $just-return) - (.visitInsn Opcodes/POP2) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 2)) - (.visitInsn Opcodes/AALOAD) - (.visitInsn Opcodes/ARETURN) - (.visitLabel $further) ;; tag, sum-tag - (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum - (.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index? - (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last? - (.visitJumpInsn Opcodes/IFNULL $not-right) ;; tag, sum-tag - (.visitInsn Opcodes/ISUB) ;; sub-tag - (.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum - (.visitLdcInsn (int 2)) ;; sub-tag, sum, sub-sum-idx - (.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag - (.visitVarInsn Opcodes/ISTORE 1) ;; - (.visitJumpInsn Opcodes/GOTO $begin) - (.visitLabel $not-right) ;; tag, sum-tag - (.visitInsn Opcodes/POP2) - (.visitInsn Opcodes/ACONST_NULL) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [;; $is-null (new Label) - ] - ;; I commented out some parts because a null-check was - ;; done to ensure variants were never created with null - ;; values (this would interfere later with - ;; pattern-matching). - ;; Since Lux itself doesn't have null values as part of - ;; the language, the burden of ensuring non-nulls was - ;; shifted to library code dealing with host-interop, to - ;; ensure variant-making was as fast as possible. - ;; The null-checking code was left as comments in case I - ;; ever change my mind. - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - ;; (.visitVarInsn Opcodes/ALOAD 2) - ;; (.visitJumpInsn Opcodes/IFNULL $is-null) - (.visitLdcInsn (int 3)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ILOAD 0) - (&&/wrap-int) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 2)) - (.visitVarInsn Opcodes/ALOAD 2) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/ARETURN) - ;; (.visitLabel $is-null) - ;; (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") - ;; (.visitInsn Opcodes/DUP) - ;; (.visitLdcInsn "Can't create variant for null pointer") - ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") - ;; (.visitInsn Opcodes/ATHROW) - (.visitMaxs 0 0) - (.visitEnd)))] - nil)) - -(defn ^:private low-4b [^MethodVisitor =method] - (doto =method - ;; Assume there is a long at the top of the stack... - ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits. - (.visitLdcInsn (int -1)) - (.visitInsn Opcodes/I2L) - ;; Then do a bitwise and. - (.visitInsn Opcodes/LAND) - )) - -(defn ^:private high-4b [^MethodVisitor =method] - (doto =method - ;; Assume there is a long at the top of the stack... - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - )) - -(defn ^:private swap2 [^MethodVisitor =method] - (doto =method - ;; X2, Y2 - (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2 - (.visitInsn Opcodes/POP2) ;; Y2, X2 - )) - -(defn ^:private bit-set-64? [^MethodVisitor =method] - (doto =method - ;; L, I - (.visitLdcInsn (long 1)) ;; L, I, L - (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L - (.visitInsn Opcodes/POP2) ;; L, L, I - (.visitInsn Opcodes/LSHL) ;; L, L - (.visitInsn Opcodes/LAND) ;; L - (.visitLdcInsn (long 0)) ;; L, L - (.visitInsn Opcodes/LCMP) ;; I - )) - -(defn ^:private compile-LuxRT-frac-methods [^ClassWriter =class] - (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_frac" "(JJ)J" nil nil) - ;; Based on: http://stackoverflow.com/a/31629280/6823464 - (.visitCode) - ;; Bottom part - (.visitVarInsn Opcodes/LLOAD 0) low-4b - (.visitVarInsn Opcodes/LLOAD 2) low-4b - (.visitInsn Opcodes/LMUL) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - ;; Middle part - (.visitVarInsn Opcodes/LLOAD 0) high-4b - (.visitVarInsn Opcodes/LLOAD 2) low-4b - (.visitInsn Opcodes/LMUL) - (.visitVarInsn Opcodes/LLOAD 0) low-4b - (.visitVarInsn Opcodes/LLOAD 2) high-4b - (.visitInsn Opcodes/LMUL) - (.visitInsn Opcodes/LADD) - ;; Join middle and bottom - (.visitInsn Opcodes/LADD) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - ;; Top part - (.visitVarInsn Opcodes/LLOAD 0) high-4b - (.visitVarInsn Opcodes/LLOAD 2) high-4b - (.visitInsn Opcodes/LMUL) - ;; Join top with rest - (.visitInsn Opcodes/LADD) - ;; Return - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_frac" "(JJ)J" nil nil) - (.visitCode) - ;; Based on: http://stackoverflow.com/a/8510587/6823464 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) high-4b - (.visitInsn Opcodes/LDIV) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LSHL) - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "frac-to-real" "(J)D" nil nil) - (.visitCode) - ;; Translate high bytes - (.visitVarInsn Opcodes/LLOAD 0) high-4b - (.visitInsn Opcodes/L2D) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DDIV) - ;; Translate low bytes - (.visitVarInsn Opcodes/LLOAD 0) low-4b - (.visitInsn Opcodes/L2D) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DDIV) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DDIV) - ;; Combine and return - (.visitInsn Opcodes/DADD) - (.visitInsn Opcodes/DRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-frac" "(D)J" nil nil) - (.visitCode) - ;; Drop any excess - (.visitVarInsn Opcodes/DLOAD 0) - (.visitLdcInsn (double 1.0)) - (.visitInsn Opcodes/DREM) - ;; Shift upper half, but retain remaining decimals - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DMUL) - ;; Make a copy, so the lower half can be extracted - (.visitInsn Opcodes/DUP2) - ;; Get that lower half - (.visitLdcInsn (double 1.0)) - (.visitInsn Opcodes/DREM) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DMUL) - ;; Turn it into a frac - (.visitInsn Opcodes/D2L) - ;; Turn the upper half into frac too - swap2 - (.visitInsn Opcodes/D2L) - ;; Combine both pieces - (.visitInsn Opcodes/LADD) - ;; FINISH - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (let [$start (new Label) - $body (new Label) - $end (new Label) - $zero (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "count_bin_start_0" "(J)I" nil nil) - (.visitCode) - ;; Initialize counter - (.visitLdcInsn (int 0)) ; I - (.visitVarInsn Opcodes/ISTORE 2) ; - ;; Initialize index var - (.visitLdcInsn (int 63)) ; I - ;; Begin loop - (.visitLabel $start) ; I - ;; Make sure we're still on the valid index range - (.visitInsn Opcodes/DUP) ; I, I - (.visitLdcInsn (int -1)) ; I, I, I - (.visitJumpInsn Opcodes/IF_ICMPGT $body) ; I - ;; If not, just return what we've got. - (.visitInsn Opcodes/POP) ; - (.visitVarInsn Opcodes/ILOAD 2) ; I - (.visitJumpInsn Opcodes/GOTO $end) - ;; If so, run the body - (.visitLabel $body) ;; I - (.visitInsn Opcodes/DUP) ;; I, I - (.visitVarInsn Opcodes/LLOAD 0) ;; I, I, L - (.visitInsn Opcodes/DUP2_X1) ;; I, L, I, L - (.visitInsn Opcodes/POP2) ;; I, L, I - bit-set-64? ;; I, I - (.visitJumpInsn Opcodes/IFEQ $zero) ;; I - ;; No more zeroes from now on... - (.visitInsn Opcodes/POP) ;; - (.visitVarInsn Opcodes/ILOAD 2) ;; I - (.visitJumpInsn Opcodes/GOTO $end) - ;; Found another zero... - (.visitLabel $zero) ;; I - ;; Increase counter - (.visitVarInsn Opcodes/ILOAD 2) ;; I, I - (.visitLdcInsn (int 1)) ;; I, I, I - (.visitInsn Opcodes/IADD) ;; I, I - (.visitVarInsn Opcodes/ISTORE 2) ;; I - ;; Increase index, then iterate again... - (.visitLdcInsn (int 1)) ;; I, I - (.visitInsn Opcodes/ISUB) ;; I - (.visitJumpInsn Opcodes/GOTO $start) - ;; Finally, return - (.visitLabel $end) ; I - (.visitInsn Opcodes/IRETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$start (new Label) - $can-append (new Label) - $end (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_text_start_0" "(J)Ljava/lang/String;" nil nil) - (.visitCode) - ;; Initialize accum - (.visitLdcInsn "") ;; S - (.visitVarInsn Opcodes/ASTORE 2) ;; - ;; Initialize comparator - (.visitLdcInsn (long 10)) ;; L - ;; Testing/accum loop - (.visitLabel $start) ;; L - (.visitInsn Opcodes/DUP2) ;; L, L - (.visitVarInsn Opcodes/LLOAD 0) ;; L, L, L - (.visitInsn Opcodes/LCMP) ;; L, I - (.visitJumpInsn Opcodes/IFLT $can-append) ;; L - ;; No more testing. - ;; Throw away the comparator and return accum. - (.visitInsn Opcodes/POP2) ;; - (.visitVarInsn Opcodes/ALOAD 2) ;; S - (.visitJumpInsn Opcodes/GOTO $end) - ;; Can keep accumulating - (.visitLabel $can-append) ;; L - ;; Add one more 0 to accum - (.visitVarInsn Opcodes/ALOAD 2) ;; L, S - (.visitLdcInsn "0") ;; L, S, S - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") ;; L, S - (.visitVarInsn Opcodes/ASTORE 2) ;; L - ;; Update comparator and re-iterate - (.visitLdcInsn (long 10)) ;; L, L - (.visitInsn Opcodes/LMUL) ;; L - (.visitJumpInsn Opcodes/GOTO $start) - (.visitLabel $end) ;; S - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$is-zero (new Label) - $end (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_frac" "(J)Ljava/lang/String;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFEQ $is-zero) - ;; IF =/= 0 - ;; Generate leading 0s - (.visitLdcInsn (long 1)) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_bin_start_0" "(J)I") - (.visitInsn Opcodes/LSHL) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_text_start_0" "(J)Ljava/lang/String;") - ;; Convert to number text - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toUnsignedString" "(J)Ljava/lang/String;") - ;; Remove unnecessary trailing zeroes - (.visitLdcInsn "0*$") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;") - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - ;; Join leading 0s with number text - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - ;; FINISH - (.visitJumpInsn Opcodes/GOTO $end) - ;; IF == 0 - (.visitLabel $is-zero) - (.visitLdcInsn ".0") - (.visitLabel $end) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$end (new Label) - ;; $then (new Label) - $else (new Label) - $from (new Label) - $to (new Label) - $handler (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_frac" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) - (.visitCode) - ;; Check prefix - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn ".") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z") - (.visitJumpInsn Opcodes/IFEQ $else) - ;; Remove prefix - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitInsn Opcodes/DUP) - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitLabel $from) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "read_frac_text" "(Ljava/lang/String;)J") - (.visitLabel $to) - (.visitInsn Opcodes/DUP2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_bin_start_0" "(J)I") - (.visitInsn Opcodes/LSHL) - (.visitInsn Opcodes/DUP2_X1) - (.visitInsn Opcodes/POP2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_leading_zeroes" "(Ljava/lang/String;)J") - (.visitInsn Opcodes/L2D) - (.visitLdcInsn (double 10.0)) - swap2 - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "pow" "(DD)D") - (.visitInsn Opcodes/D2L) - (.visitInsn Opcodes/LDIV) - ;; (.visitJumpInsn Opcodes/GOTO $then) - ;; (.visitLabel $then) - (&&/wrap-long) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $handler) - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Exception"])) - (.visitInsn Opcodes/POP) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) - (.visitJumpInsn Opcodes/GOTO $end) - ;; Doesn't start with necessary prefix. - (.visitLabel $else) - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 0 (to-array [])) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitLabel $end) - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [string-bcn (&host-generics/->bytecode-class-name "java.lang.String") - $valid (new Label) - $end (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "count_leading_zeroes" "(Ljava/lang/String;)J" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) ;; S - (.visitLdcInsn "^0*") ;; S, S - (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "split" "(Ljava/lang/String;)[Ljava/lang/String;") ;; [S - (.visitInsn Opcodes/DUP) ;; [S, [S - (.visitInsn Opcodes/ARRAYLENGTH) ;; [S, I - (.visitLdcInsn (int 2)) ;; [S, I, I - (.visitJumpInsn Opcodes/IF_ICMPEQ $valid) ;; [S - ;; Invalid... - (.visitInsn Opcodes/POP) ;; - (.visitLdcInsn (long 0)) ;; J - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $valid) ;; [S - ;; Valid... - (.visitLdcInsn (int 1)) ;; [S, I - (.visitInsn Opcodes/AALOAD) ;; S - (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "length" "()I") ;; I - (.visitVarInsn Opcodes/ALOAD 0) ;; I, S - (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "length" "()I") ;; I, I - (.visitInsn Opcodes/SWAP) ;; I, I - (.visitInsn Opcodes/ISUB) ;; I - (.visitInsn Opcodes/I2L) ;; J - (.visitLabel $end) ;; J - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$only-zeroes (new Label) - $end (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "read_frac_text" "(Ljava/lang/String;)J" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn "0*$") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL - (&host-generics/->bytecode-class-name "java.lang.String") - "split" "(Ljava/lang/String;)[Ljava/lang/String;") - (.visitInsn Opcodes/DUP) - (.visitInsn Opcodes/ARRAYLENGTH) - (.visitJumpInsn Opcodes/IFEQ $only-zeroes) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J") - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $only-zeroes) - (.visitInsn Opcodes/POP) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J") - (.visitLabel $end) - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ] - nil)) - -(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] - (defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class] - (|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677 - _ (let [$from (new Label) - $to (new Label) - $handler (new Label) - - $good-start (new Label) - $short-enough (new Label) - $bad-digit (new Label) - $out-of-bounds (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitLabel $from) - ;; Remove the + at the beginning... - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 0)) - (.visitLdcInsn (int 0)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") - (.visitLdcInsn "+") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (.visitJumpInsn Opcodes/IFNE $good-start) - ;; Doesn't start with + - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;; Starts with + - (.visitLabel $good-start) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") - (.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix... - ;; Begin parsing processs - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitLdcInsn (int 18)) - (.visitJumpInsn Opcodes/IF_ICMPLE $short-enough) - ;; Too long - ;; Get prefix... - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") - (.visitInsn Opcodes/DUP2) ;; Clone prefix, for later... - ;; Get last digit... - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") - (.visitLdcInsn (int 10)) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I") - ;; Test last digit... - (.visitInsn Opcodes/DUP) - (.visitJumpInsn Opcodes/IFLT $bad-digit) - ;; Good digit... - ;; Stack: prefix::L, prefix::L, last-digit::I - (.visitInsn Opcodes/I2L) - ;; Build the result... - swap2 - (.visitLdcInsn (long 10)) - (.visitInsn Opcodes/LMUL) - (.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L - (.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L - swap2 ;; Stack: result::L, result::L, prefix::L - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitJumpInsn Opcodes/IFLT $out-of-bounds) - ;; Within bounds - ;; Stack: result::L - &&/wrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;; Out of bounds - (.visitLabel $out-of-bounds) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;; Bad digit... - (.visitLabel $bad-digit) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;; 18 chars or less - (.visitLabel $short-enough) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") - &&/wrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitLabel $to) - (.visitLabel $handler) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172 - _ (let [$too-big (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil) - (.visitCode) - (.visitLdcInsn "+") - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFLT $too-big) - ;; then - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitInsn Opcodes/ARETURN) - ;; else - (.visitLabel $too-big) - ;; Set up parts of the number string... - ;; First digits - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/LUSHR) - (.visitLdcInsn (long 5)) - (.visitInsn Opcodes/LDIV) ;; quot - ;; Last digit - (.visitInsn Opcodes/DUP2) - (.visitLdcInsn (long 10)) - (.visitInsn Opcodes/LMUL) - (.visitVarInsn Opcodes/LLOAD 0) - swap2 - (.visitInsn Opcodes/LSUB) ;; quot, rem - ;; Conversion to string... - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem* - (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem* - (.visitInsn Opcodes/POP) ;; rem*, quot - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot* - (.visitInsn Opcodes/SWAP) ;; quot*, rem* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 - _ (let [$simple-case (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFGE $simple-case) - ;; else - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") - (.visitLdcInsn (int 32)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;") - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LSHL) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") - (.visitInsn Opcodes/ARETURN) - ;; then - (.visitLabel $simple-case) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") - (.visitInsn Opcodes/LADD) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") - (.visitInsn Opcodes/LADD) - (.visitInsn Opcodes/LCMP) - (.visitInsn Opcodes/IRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 - _ (let [$case-1 (new Label) - $0 (new Label) - $case-2 (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil) - (.visitCode) - ;; Test #1 - (.visitVarInsn Opcodes/LLOAD 2) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFLT $case-1) - ;; Test #2 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFGT $case-2) - ;; Case #3 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") - (.visitVarInsn Opcodes/LLOAD 2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") - (.visitInsn Opcodes/LRETURN) - ;; Case #2 - (.visitLabel $case-2) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitInsn Opcodes/LDIV) - (.visitInsn Opcodes/LRETURN) - ;; Case #1 - (.visitLabel $case-1) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitJumpInsn Opcodes/IFLT $0) - ;; 1 - (.visitLdcInsn (long 1)) - (.visitInsn Opcodes/LRETURN) - ;; 0 - (.visitLabel $0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 - _ (let [$test-2 (new Label) - $case-2 (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil) - (.visitCode) - ;; Test #1 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFLE $test-2) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFLE $test-2) - ;; Case #1 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitInsn Opcodes/LREM) - (.visitInsn Opcodes/LRETURN) - ;; Test #2 - (.visitLabel $test-2) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitJumpInsn Opcodes/IFLT $case-2) - ;; Case #3 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") - (.visitVarInsn Opcodes/LLOAD 2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") - (.visitInsn Opcodes/LRETURN) - ;; Case #2 - (.visitLabel $case-2) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitInsn Opcodes/LRETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitMaxs 0 0) - (.visitEnd)))] - nil))) - -(defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class] - (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil) - (.visitCode) - (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn "Invalid expression for pattern-matching.") - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") - (.visitInsn Opcodes/ATHROW) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLdcInsn (int 2)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))] - nil)) - -(def compile-LuxRT-class - (|do [_ (return nil) - :let [full-name &&/lux-utils-class - super-class (&host-generics/->bytecode-class-name "java.lang.Object") - tag-sig (&host-generics/->type-signature "java.lang.String") - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - full-name nil super-class (into-array String []))) - =unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag) - (.visitEnd)) - =init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") - (.visitLdcInsn "LOG: ") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V") - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; I - (.visitInsn Opcodes/ACONST_NULL) ;; I? - (.visitLdcInsn &/unit-tag) ;; I?U - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I - (.visitInsn Opcodes/ACONST_NULL) ;; I? - (.visitVarInsn Opcodes/ALOAD 0) ;; I?O - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn ",|_") - (.visitLdcInsn "") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto =class - (compile-LuxRT-pm-methods) - (compile-LuxRT-adt-methods) - (compile-LuxRT-nat-methods) - (compile-LuxRT-frac-methods))]] - (&&/save-class! (second (string/split &&/lux-utils-class #"/")) - (.toByteArray (doto =class .visitEnd))))) - -(defn ^:private compile-jvm-try [compile ?values special-args] - (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - :let [$from (new Label) - $to (new Label) - $handler (new Label) - $end (new Label)] - :let [_ (doto *writer* - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitLabel $from))] - _ (compile ?body) - :let [_ (doto *writer* - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $to) - (.visitLabel $handler))] - _ (compile ?catch) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] - :let [_ (.visitLabel *writer* $end)]] - (return nil))) - -(do-template [ ] - (defn [compile _?value special-args] - (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW (&host-generics/->bytecode-class-name )) - (.visitInsn Opcodes/DUP))] - _ (compile ?value) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name )) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name ) ) - (.visitInsn ) - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name ) init-method ))]] - (return nil))) - - ^:private compile-jvm-d2f Opcodes/D2F "java.lang.Double" "doubleValue" "()D" "java.lang.Float" "(F)V" - ^:private compile-jvm-d2i Opcodes/D2I "java.lang.Double" "doubleValue" "()D" "java.lang.Integer" "(I)V" - ^:private compile-jvm-d2l Opcodes/D2L "java.lang.Double" "doubleValue" "()D" "java.lang.Long" "(J)V" - - ^:private compile-jvm-f2d Opcodes/F2D "java.lang.Float" "floatValue" "()F" "java.lang.Double" "(D)V" - ^:private compile-jvm-f2i Opcodes/F2I "java.lang.Float" "floatValue" "()F" "java.lang.Integer" "(I)V" - ^:private compile-jvm-f2l Opcodes/F2L "java.lang.Float" "floatValue" "()F" "java.lang.Long" "(J)V" - - ^:private compile-jvm-i2b Opcodes/I2B "java.lang.Integer" "intValue" "()I" "java.lang.Byte" "(B)V" - ^:private compile-jvm-i2c Opcodes/I2C "java.lang.Integer" "intValue" "()I" "java.lang.Character" "(C)V" - ^:private compile-jvm-i2d Opcodes/I2D "java.lang.Integer" "intValue" "()I" "java.lang.Double" "(D)V" - ^:private compile-jvm-i2f Opcodes/I2F "java.lang.Integer" "intValue" "()I" "java.lang.Float" "(F)V" - ^:private compile-jvm-i2l Opcodes/I2L "java.lang.Integer" "intValue" "()I" "java.lang.Long" "(J)V" - ^:private compile-jvm-i2s Opcodes/I2S "java.lang.Integer" "intValue" "()I" "java.lang.Short" "(S)V" - - ^:private compile-jvm-l2d Opcodes/L2D "java.lang.Long" "longValue" "()J" "java.lang.Double" "(D)V" - ^:private compile-jvm-l2f Opcodes/L2F "java.lang.Long" "longValue" "()J" "java.lang.Float" "(F)V" - ^:private compile-jvm-l2i Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Integer" "(I)V" - ^:private compile-jvm-l2s Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Short" "(S)V" - ^:private compile-jvm-l2b Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Byte" "(B)V" - - ^:private compile-jvm-c2b Opcodes/I2B "java.lang.Character" "charValue" "()C" "java.lang.Byte" "(B)V" - ^:private compile-jvm-c2s Opcodes/I2S "java.lang.Character" "charValue" "()C" "java.lang.Short" "(S)V" - ^:private compile-jvm-c2i Opcodes/NOP "java.lang.Character" "charValue" "()C" "java.lang.Integer" "(I)V" - ^:private compile-jvm-c2l Opcodes/I2L "java.lang.Character" "charValue" "()C" "java.lang.Long" "(J)V" - - ^:private compile-jvm-s2l Opcodes/I2L "java.lang.Short" "shortValue" "()S" "java.lang.Long" "(J)V" - - ^:private compile-jvm-b2l Opcodes/I2L "java.lang.Byte" "byteValue" "()B" "java.lang.Long" "(J)V" - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW (&host-generics/->bytecode-class-name )) - (.visitInsn Opcodes/DUP))] - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name )) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name ) ))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name )) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name ) ))] - :let [_ (doto *writer* - (.visitInsn ) - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name ) init-method ))]] - (return nil))) - - ^:private compile-jvm-iand Opcodes/IAND "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" - ^:private compile-jvm-ior Opcodes/IOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" - ^:private compile-jvm-ixor Opcodes/IXOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" - ^:private compile-jvm-ishl Opcodes/ISHL "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" - ^:private compile-jvm-ishr Opcodes/ISHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" - ^:private compile-jvm-iushr Opcodes/IUSHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" - - ^:private compile-jvm-land Opcodes/LAND "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" - ^:private compile-jvm-lor Opcodes/LOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" - ^:private compile-jvm-lxor Opcodes/LXOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" - ^:private compile-jvm-lshl Opcodes/LSHL "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" - ^:private compile-jvm-lshr Opcodes/LSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" - ^:private compile-jvm-lushr Opcodes/LUSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - :let [+wrapper-class+ (&host-generics/->bytecode-class-name )] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) - _ (doto *writer* - (.visitInsn ) - ())]] - (return nil))) - - ^:private compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" &&/wrap-int - ^:private compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" &&/wrap-int - ^:private compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" &&/wrap-int - ^:private compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" &&/wrap-int - ^:private compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" &&/wrap-int - - ^:private compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long - ^:private compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long - ^:private compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long - ^:private compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" &&/wrap-long - ^:private compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" &&/wrap-long - - ^:private compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" &&/wrap-float - ^:private compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" &&/wrap-float - ^:private compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" &&/wrap-float - ^:private compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" &&/wrap-float - ^:private compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" &&/wrap-float - - ^:private compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" &&/wrap-double - ^:private compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" &&/wrap-double - ^:private compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" &&/wrap-double - ^:private compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" &&/wrap-double - ^:private compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" &&/wrap-double - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - :let [+wrapper-class+ (&host-generics/->bytecode-class-name )] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitJumpInsn $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - - ^:private compile-jvm-ieq Opcodes/IF_ICMPEQ "java.lang.Integer" "intValue" "()I" - ^:private compile-jvm-ilt Opcodes/IF_ICMPLT "java.lang.Integer" "intValue" "()I" - ^:private compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I" - - ^:private compile-jvm-ceq Opcodes/IF_ICMPEQ "java.lang.Character" "charValue" "()C" - ^:private compile-jvm-clt Opcodes/IF_ICMPLT "java.lang.Character" "charValue" "()C" - ^:private compile-jvm-cgt Opcodes/IF_ICMPGT "java.lang.Character" "charValue" "()C" - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - :let [+wrapper-class+ (&host-generics/->bytecode-class-name )] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitInsn ) - (.visitLdcInsn (int )) - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - - ^:private compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" - ^:private compile-jvm-llt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" - ^:private compile-jvm-lgt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J" - - ^:private compile-jvm-feq Opcodes/FCMPG 0 "java.lang.Float" "floatValue" "()F" - ^:private compile-jvm-flt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F" - ^:private compile-jvm-fgt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F" - - ^:private compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()D" - ^:private compile-jvm-dlt Opcodes/DCMPG -1 "java.lang.Double" "doubleValue" "()D" - ^:private compile-jvm-dgt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()D" - ) - -(do-template [ ] - (do (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?length (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?length) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY )]] - (return nil))) - - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (doto *writer* - (.visitInsn ) - )]] - (return nil))) - - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] - :let [_ (.visitInsn *writer* Opcodes/DUP)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - _ (compile ?elem) - :let [_ (doto *writer* - - (.visitInsn ))]] - (return nil))) - ) - - Opcodes/T_BOOLEAN "[Z" ^:private compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean - Opcodes/T_BYTE "[B" ^:private compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte - Opcodes/T_SHORT "[S" ^:private compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short - Opcodes/T_INT "[I" ^:private compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int - Opcodes/T_LONG "[J" ^:private compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long - Opcodes/T_FLOAT "[F" ^:private compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float - Opcodes/T_DOUBLE "[D" ^:private compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double - Opcodes/T_CHAR "[C" ^:private compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char - ) - -(defn ^:private compile-jvm-anewarray [compile ?values special-args] - (|do [:let [(&/$Cons ?length (&/$Nil)) ?values - (&/$Cons ?gclass (&/$Cons type-env (&/$Nil))) special-args] - ^MethodVisitor *writer* &/get-writer - _ (compile ?length) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]] - (return nil))) - -(defn ^:private compile-jvm-aaload [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - array-type (&host/->java-sig (&a/expr-type* ?array)) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] - (return nil))) - -(defn ^:private compile-jvm-aastore [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - array-type (&host/->java-sig (&a/expr-type* ?array)) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - :let [_ (.visitInsn *writer* Opcodes/DUP)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - _ (compile ?elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return nil))) - -(defn ^:private compile-jvm-arraylength [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - array-type (&host/->java-sig (&a/expr-type* ?array)) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - :let [_ (doto *writer* - (.visitInsn Opcodes/ARRAYLENGTH) - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) - -(defn ^:private compile-jvm-null [compile ?values special-args] - (|do [:let [;; (&/$Nil) ?values - (&/$Nil) special-args] - ^MethodVisitor *writer* &/get-writer - :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] - (return nil))) - -(defn ^:private compile-jvm-null? [compile ?values special-args] - (|do [:let [(&/$Cons ?object (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?object) - :let [$then (new Label) - $end (new Label) - _ (doto *writer* - (.visitJumpInsn Opcodes/IFNULL $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - -(defn compile-jvm-synchronized [compile ?values special-args] - (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?monitor) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitInsn Opcodes/MONITORENTER))] - _ (compile ?expr) - :let [_ (doto *writer* - (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/MONITOREXIT))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?monitor (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?monitor) - :let [_ (doto *writer* - (.visitInsn ) - (.visitInsn Opcodes/ACONST_NULL))]] - (return nil))) - - ^:private compile-jvm-monitorenter Opcodes/MONITORENTER - ^:private compile-jvm-monitorexit Opcodes/MONITOREXIT - ) - -(defn ^:private compile-jvm-throw [compile ?values special-args] - (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?ex) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) - -(defn ^:private compile-jvm-getstatic [compile ?values special-args] - (|do [:let [;; (&/$Nil) ?values - (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] - ^MethodVisitor *writer* &/get-writer - =output-type (&host/->java-sig ?output-type) - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type) - (prepare-return! ?output-type))]] - (return nil))) - -(defn ^:private compile-jvm-getfield [compile ?values special-args] - (|do [:let [(&/$Cons ?object (&/$Nil)) ?values - (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] - :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - _ (compile ?object) - =output-type (&host/->java-sig ?output-type) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST class*) - (.visitFieldInsn Opcodes/GETFIELD class* ?field =output-type) - (prepare-return! ?output-type))]] - (return nil))) - -(defn ^:private compile-jvm-putstatic [compile ?values special-args] - (|do [:let [(&/$Cons ?value (&/$Nil)) ?values - (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Nil)))) special-args] - ^MethodVisitor *writer* &/get-writer - _ (compile ?value) - :let [=input-sig (&host-type/gclass->sig input-gclass) - _ (doto *writer* - (prepare-arg! (&host-generics/gclass->class-name input-gclass)) - (.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig) - (.visitInsn Opcodes/ACONST_NULL))]] - (return nil))) - -(defn ^:private compile-jvm-putfield [compile ?values special-args] - (|do [:let [(&/$Cons ?object (&/$Cons ?value (&/$Nil))) ?values - (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Cons ?input-type (&/$Nil))))) special-args] - :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] - _ (compile ?value) - =input-sig (&host/->java-sig ?input-type) - :let [_ (doto *writer* - (prepare-arg! (&host-generics/gclass->class-name input-gclass)) - (.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig) - (.visitInsn Opcodes/ACONST_NULL))]] - (return nil))) - -(defn ^:private compile-jvm-invokestatic [compile ?values special-args] - (|do [:let [?args ?values - (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] - ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] - _ (&/map2% (fn [class-name arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - ?classes ?args) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig) - (prepare-return! ?output-type))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?object ?args) ?values - (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] - :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] - _ (compile ?object) - :let [_ (when (not= "" ?method) - (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] - _ (&/map2% (fn [class-name arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - ?classes ?args) - :let [_ (doto *writer* - (.visitMethodInsn ?class* ?method method-sig) - (prepare-return! ?output-type))]] - (return nil))) - - ^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL - ^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE - ^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL - ) - -(defn ^:private compile-jvm-new [compile ?values special-args] - (|do [:let [?args ?values - (&/$Cons ?class (&/$Cons ?classes (&/$Nil))) special-args] - ^MethodVisitor *writer* &/get-writer - :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V") - class* (&host-generics/->bytecode-class-name ?class) - _ (doto *writer* - (.visitTypeInsn Opcodes/NEW class*) - (.visitInsn Opcodes/DUP))] - _ (&/map% (fn [class-name+arg] - (|do [:let [[class-name arg] class-name+arg] - ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (&/zip2 ?classes ?args)) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESPECIAL class* "" init-sig))]] - (return nil))) - -(defn ^:private compile-jvm-try [compile ?values special-args] - (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - :let [$from (new Label) - $to (new Label) - $handler (new Label) - $end (new Label)] - :let [_ (doto *writer* - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitLabel $from))] - _ (compile ?body) - :let [_ (doto *writer* - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $to) - (.visitLabel $handler))] - _ (compile ?catch) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] - :let [_ (.visitLabel *writer* $end)]] - (return nil))) - -(defn ^:private compile-jvm-load-class [compile ?values special-args] - (|do [:let [(&/$Cons _class-name (&/$Cons ?output-type (&/$Nil))) special-args] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn _class-name) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Class" "forName" "(Ljava/lang/String;)Ljava/lang/Class;") - (prepare-return! ?output-type))]] - (return nil))) - -(defn ^:private compile-jvm-instanceof [compile ?values special-args] - (|do [:let [(&/$Cons object (&/$Nil)) ?values - (&/$Cons class (&/$Nil)) special-args] - :let [class* (&host-generics/->bytecode-class-name class)] - ^MethodVisitor *writer* &/get-writer - _ (compile object) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/INSTANCEOF class*) - (&&/wrap-boolean))]] - (return nil))) - -(defn ^:private compile-array-get [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - array-type (&host/->java-sig (&a/expr-type* ?array)) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitInsn *writer* Opcodes/AALOAD)] - :let [$is-null (new Label) - $end (new Label) - _ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitJumpInsn Opcodes/IFNULL $is-null) - (.visitLdcInsn (int 1)) - (.visitLdcInsn "") - (.visitInsn Opcodes/DUP2_X1) ;; I?2I? - (.visitInsn Opcodes/POP2) ;; I?2 - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $is-null) - (.visitInsn Opcodes/POP) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/ACONST_NULL) - (.visitLdcInsn &/unit-tag) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitLabel $end))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (&&/unwrap-long *writer*)] - _ (compile ?mask) - :let [_ (&&/unwrap-long *writer*)] - :let [_ (doto *writer* - (.visitInsn ) - &&/wrap-long)]] - (return nil))) - - ^:private compile-bit-and Opcodes/LAND - ^:private compile-bit-or Opcodes/LOR - ^:private compile-bit-xor Opcodes/LXOR - ) - -(defn ^:private compile-bit-count [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (&&/unwrap-long *writer*)] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (&&/unwrap-long *writer*)] - _ (compile ?shift) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (doto *writer* - (.visitInsn ) - &&/wrap-long)]] - (return nil))) - - ^:private compile-bit-shift-left Opcodes/LSHL - ^:private compile-bit-shift-right Opcodes/LSHR - ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR - ) - -(defn ^:private compile-lux-== [compile ?values special-args] - (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?left) - _ (compile ?right) - :let [$then (new Label) - $end (new Label) - _ (doto *writer* - (.visitJumpInsn Opcodes/IF_ACMPEQ $then) - ;; else - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") - (.visitLabel $end))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - :let [+wrapper-class+ (&host-generics/->bytecode-class-name )] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) - _ (doto *writer* - (.visitInsn ) - ())]] - (return nil))) - - ^:private compile-nat-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long - ^:private compile-nat-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long - ^:private compile-nat-mul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long - - ^:private compile-frac-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long - ^:private compile-frac-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long - ^:private compile-frac-rem Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long - ^:private compile-frac-scale Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J")) - _ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") - (&&/wrap-long))]] - (return nil))) - - ^:private compile-nat-div "div_nat" - ^:private compile-nat-rem "rem_nat" - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J")) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitLdcInsn (int )) - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - - ^:private compile-nat-eq 0 - - ^:private compile-frac-eq 0 - ^:private compile-frac-lt -1 - ) - -(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] - (defn ^:private compile-nat-lt [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J")) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitLdcInsn (int -1)) - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil)))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Nil) ?values] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - - )]] - (return nil))) - - ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long - ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long - - ^:private compile-frac-min-value (.visitLdcInsn 0) &&/wrap-long - ^:private compile-frac-max-value (.visitLdcInsn -1) &&/wrap-long - ) - -(do-template [ ] - (do (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] - (return nil))) - - (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] - (return nil))))) - - ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" - ^:private compile-frac-encode "encode_frac" ^:private compile-frac-decode "decode_frac" - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - &&/unwrap-long)] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - &&/unwrap-long)] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") - &&/wrap-long)]] - (return nil))) - - ^:private compile-frac-mul "mul_frac" - ^:private compile-frac-div "div_frac" - ) - -(do-template [ ] - (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) - )]] - (return nil)))) - - ^:private compile-frac-to-real "java.lang.Long" "frac-to-real" "(J)D" &&/unwrap-long &&/wrap-double - ^:private compile-real-to-frac "java.lang.Double" "real-to-frac" "(D)J" &&/unwrap-double &&/wrap-long - ) - -(let [widen (fn [^MethodVisitor *writer*] - (doto *writer* - (.visitInsn Opcodes/I2L))) - shrink (fn [^MethodVisitor *writer*] - (doto *writer* - (.visitInsn Opcodes/L2I) - (.visitInsn Opcodes/I2C)))] - (do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - - - )]] - (return nil))) - - ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink - ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen - )) - -(do-template [] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x)] - (return nil))) - - ^:private compile-nat-to-int - ^:private compile-int-to-nat - ) - -(defn compile-host [compile proc-category proc-name ?values special-args] - (case proc-category - "lux" - (case proc-name - "==" (compile-lux-== compile ?values special-args)) - - "bit" - (case proc-name - "count" (compile-bit-count compile ?values special-args) - "and" (compile-bit-and compile ?values special-args) - "or" (compile-bit-or compile ?values special-args) - "xor" (compile-bit-xor compile ?values special-args) - "shift-left" (compile-bit-shift-left compile ?values special-args) - "shift-right" (compile-bit-shift-right compile ?values special-args) - "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) - - "array" - (case proc-name - "get" (compile-array-get compile ?values special-args)) - - "nat" - (case proc-name - "+" (compile-nat-add compile ?values special-args) - "-" (compile-nat-sub compile ?values special-args) - "*" (compile-nat-mul compile ?values special-args) - "/" (compile-nat-div compile ?values special-args) - "%" (compile-nat-rem compile ?values special-args) - "=" (compile-nat-eq compile ?values special-args) - "<" (compile-nat-lt compile ?values special-args) - "encode" (compile-nat-encode compile ?values special-args) - "decode" (compile-nat-decode compile ?values special-args) - "max-value" (compile-nat-max-value compile ?values special-args) - "min-value" (compile-nat-min-value compile ?values special-args) - "to-int" (compile-nat-to-int compile ?values special-args) - "to-char" (compile-nat-to-char compile ?values special-args) - ) - - "frac" - (case proc-name - "+" (compile-frac-add compile ?values special-args) - "-" (compile-frac-sub compile ?values special-args) - "*" (compile-frac-mul compile ?values special-args) - "/" (compile-frac-div compile ?values special-args) - "%" (compile-frac-rem compile ?values special-args) - "=" (compile-frac-eq compile ?values special-args) - "<" (compile-frac-lt compile ?values special-args) - "encode" (compile-frac-encode compile ?values special-args) - "decode" (compile-frac-decode compile ?values special-args) - "max-value" (compile-frac-max-value compile ?values special-args) - "min-value" (compile-frac-min-value compile ?values special-args) - "to-real" (compile-frac-to-real compile ?values special-args) - "scale" (compile-frac-scale compile ?values special-args) - ) - - "int" - (case proc-name - "to-nat" (compile-int-to-nat compile ?values special-args) - ) - - "real" - (case proc-name - "to-frac" (compile-real-to-frac compile ?values special-args) - ) - - "char" - (case proc-name - "to-nat" (compile-char-to-nat compile ?values special-args) - ) - - "jvm" - (case proc-name - "synchronized" (compile-jvm-synchronized compile ?values special-args) - "load-class" (compile-jvm-load-class compile ?values special-args) - "instanceof" (compile-jvm-instanceof compile ?values special-args) - "try" (compile-jvm-try compile ?values special-args) - "new" (compile-jvm-new compile ?values special-args) - "invokestatic" (compile-jvm-invokestatic compile ?values special-args) - "invokeinterface" (compile-jvm-invokeinterface compile ?values special-args) - "invokevirtual" (compile-jvm-invokevirtual compile ?values special-args) - "invokespecial" (compile-jvm-invokespecial compile ?values special-args) - "getstatic" (compile-jvm-getstatic compile ?values special-args) - "getfield" (compile-jvm-getfield compile ?values special-args) - "putstatic" (compile-jvm-putstatic compile ?values special-args) - "putfield" (compile-jvm-putfield compile ?values special-args) - "throw" (compile-jvm-throw compile ?values special-args) - "monitorenter" (compile-jvm-monitorenter compile ?values special-args) - "monitorexit" (compile-jvm-monitorexit compile ?values special-args) - "null?" (compile-jvm-null? compile ?values special-args) - "null" (compile-jvm-null compile ?values special-args) - "anewarray" (compile-jvm-anewarray compile ?values special-args) - "aaload" (compile-jvm-aaload compile ?values special-args) - "aastore" (compile-jvm-aastore compile ?values special-args) - "arraylength" (compile-jvm-arraylength compile ?values special-args) - "znewarray" (compile-jvm-znewarray compile ?values special-args) - "bnewarray" (compile-jvm-bnewarray compile ?values special-args) - "snewarray" (compile-jvm-snewarray compile ?values special-args) - "inewarray" (compile-jvm-inewarray compile ?values special-args) - "lnewarray" (compile-jvm-lnewarray compile ?values special-args) - "fnewarray" (compile-jvm-fnewarray compile ?values special-args) - "dnewarray" (compile-jvm-dnewarray compile ?values special-args) - "cnewarray" (compile-jvm-cnewarray compile ?values special-args) - "iadd" (compile-jvm-iadd compile ?values special-args) - "isub" (compile-jvm-isub compile ?values special-args) - "imul" (compile-jvm-imul compile ?values special-args) - "idiv" (compile-jvm-idiv compile ?values special-args) - "irem" (compile-jvm-irem compile ?values special-args) - "ieq" (compile-jvm-ieq compile ?values special-args) - "ilt" (compile-jvm-ilt compile ?values special-args) - "igt" (compile-jvm-igt compile ?values special-args) - "ceq" (compile-jvm-ceq compile ?values special-args) - "clt" (compile-jvm-clt compile ?values special-args) - "cgt" (compile-jvm-cgt compile ?values special-args) - "ladd" (compile-jvm-ladd compile ?values special-args) - "lsub" (compile-jvm-lsub compile ?values special-args) - "lmul" (compile-jvm-lmul compile ?values special-args) - "ldiv" (compile-jvm-ldiv compile ?values special-args) - "lrem" (compile-jvm-lrem compile ?values special-args) - "leq" (compile-jvm-leq compile ?values special-args) - "llt" (compile-jvm-llt compile ?values special-args) - "lgt" (compile-jvm-lgt compile ?values special-args) - "fadd" (compile-jvm-fadd compile ?values special-args) - "fsub" (compile-jvm-fsub compile ?values special-args) - "fmul" (compile-jvm-fmul compile ?values special-args) - "fdiv" (compile-jvm-fdiv compile ?values special-args) - "frem" (compile-jvm-frem compile ?values special-args) - "feq" (compile-jvm-feq compile ?values special-args) - "flt" (compile-jvm-flt compile ?values special-args) - "fgt" (compile-jvm-fgt compile ?values special-args) - "dadd" (compile-jvm-dadd compile ?values special-args) - "dsub" (compile-jvm-dsub compile ?values special-args) - "dmul" (compile-jvm-dmul compile ?values special-args) - "ddiv" (compile-jvm-ddiv compile ?values special-args) - "drem" (compile-jvm-drem compile ?values special-args) - "deq" (compile-jvm-deq compile ?values special-args) - "dlt" (compile-jvm-dlt compile ?values special-args) - "dgt" (compile-jvm-dgt compile ?values special-args) - "iand" (compile-jvm-iand compile ?values special-args) - "ior" (compile-jvm-ior compile ?values special-args) - "ixor" (compile-jvm-ixor compile ?values special-args) - "ishl" (compile-jvm-ishl compile ?values special-args) - "ishr" (compile-jvm-ishr compile ?values special-args) - "iushr" (compile-jvm-iushr compile ?values special-args) - "land" (compile-jvm-land compile ?values special-args) - "lor" (compile-jvm-lor compile ?values special-args) - "lxor" (compile-jvm-lxor compile ?values special-args) - "lshl" (compile-jvm-lshl compile ?values special-args) - "lshr" (compile-jvm-lshr compile ?values special-args) - "lushr" (compile-jvm-lushr compile ?values special-args) - "d2f" (compile-jvm-d2f compile ?values special-args) - "d2i" (compile-jvm-d2i compile ?values special-args) - "d2l" (compile-jvm-d2l compile ?values special-args) - "f2d" (compile-jvm-f2d compile ?values special-args) - "f2i" (compile-jvm-f2i compile ?values special-args) - "f2l" (compile-jvm-f2l compile ?values special-args) - "i2b" (compile-jvm-i2b compile ?values special-args) - "i2c" (compile-jvm-i2c compile ?values special-args) - "i2d" (compile-jvm-i2d compile ?values special-args) - "i2f" (compile-jvm-i2f compile ?values special-args) - "i2l" (compile-jvm-i2l compile ?values special-args) - "i2s" (compile-jvm-i2s compile ?values special-args) - "l2d" (compile-jvm-l2d compile ?values special-args) - "l2f" (compile-jvm-l2f compile ?values special-args) - "l2i" (compile-jvm-l2i compile ?values special-args) - "l2s" (compile-jvm-l2s compile ?values special-args) - "l2b" (compile-jvm-l2b compile ?values special-args) - "c2b" (compile-jvm-c2b compile ?values special-args) - "c2s" (compile-jvm-c2s compile ?values special-args) - "c2i" (compile-jvm-c2i compile ?values special-args) - "c2l" (compile-jvm-c2l compile ?values special-args) - "s2l" (compile-jvm-s2l compile ?values special-args) - "b2l" (compile-jvm-b2l compile ?values special-args) - ;; else - (fail (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name]))) - - ;; else - (fail (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj deleted file mode 100644 index ecb2066cd..000000000 --- a/src/lux/compiler/io.clj +++ /dev/null @@ -1,36 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler.io - (:require (lux [base :as & :refer [|case |let |do return* return fail fail*]]) - (lux.compiler [base :as &&]) - [lux.lib.loader :as &lib])) - -;; [Utils] -(def ^:private !libs (atom nil)) - -(defn ^:private libs-imported? [] - (not (nil? @!libs))) - -(defn ^:private init-libs! [] - (reset! !libs (&lib/load))) - -;; [Resources] -(defn read-file [source-dirs ^String file-name] - (|case (&/|some (fn [source-dir] - (let [file (new java.io.File (str source-dir "/" file-name))] - (if (.exists file) - (&/$Some file) - &/$None))) - source-dirs) - (&/$Some file) - (return (slurp file)) - - (&/$None) - (do (when (not (libs-imported?)) - (init-libs!)) - (if-let [code (get @!libs file-name)] - (return code) - (fail (str "[I/O Error] File doesn't exist: " file-name)))))) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj deleted file mode 100644 index c0096523f..000000000 --- a/src/lux/compiler/lambda.clj +++ /dev/null @@ -1,286 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler.lambda - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |case |let]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [host :as &host] - [optimizer :as &o]) - [lux.host.generics :as &host-generics] - [lux.analyser.base :as &a] - (lux.compiler [base :as &&])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) - -;; [Utils] -(def ^:private field-sig (&host-generics/->type-signature "java.lang.Object")) -(def ^:private lambda-return-sig (&host-generics/->type-signature "java.lang.Object")) -(def ^:private -return "V") - -(defn ^:private ^String reset-signature [function-class] - (str "()" (&host-generics/->type-signature function-class))) - -(defn ^:private ^MethodVisitor get-num-partials! [^MethodVisitor method-writer] - (doto method-writer - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD &&/function-class &&/partials-field "I"))) - -(defn ^:private ^MethodVisitor inc-int! [^MethodVisitor method-writer by] - (doto method-writer - (.visitLdcInsn (int by)) - (.visitInsn Opcodes/IADD))) - -(defn ^:private ^MethodVisitor get-field! [^MethodVisitor method-writer class-name field-name] - (doto method-writer - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name field-name field-sig))) - -(defn ^:private ^MethodVisitor put-field! [^MethodVisitor method-writer class-name field-name field-sig value-thunk] - (doto method-writer - (.visitVarInsn Opcodes/ALOAD 0) - value-thunk - (.visitFieldInsn Opcodes/PUTFIELD class-name field-name field-sig))) - -(defn ^:private ^MethodVisitor fill-nulls! [^MethodVisitor method-writer amount] - (doto method-writer - (-> (.visitInsn Opcodes/ACONST_NULL) - (->> (dotimes [_ amount]))))) - -(defn ^:private ^MethodVisitor consecutive-args [^MethodVisitor method-writer start amount] - (doto method-writer - (-> (.visitVarInsn Opcodes/ALOAD (+ start idx)) - (->> (dotimes [idx amount]))))) - -(defn ^:private ^MethodVisitor consecutive-applys [^MethodVisitor method-writer start amount] - (let [max-args-num (min amount &&/num-apply-variants)] - (doto method-writer - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (consecutive-args start max-args-num) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature max-args-num)) - (-> (consecutive-applys (+ start &&/num-apply-variants) (- amount &&/num-apply-variants)) - (->> (when (> amount &&/num-apply-variants))))))) - -(defn ^:private lambda-impl-signature [arity] - (str "(" (&/fold str "" (&/|repeat arity field-sig)) ")" lambda-return-sig)) - -(defn ^:private lambda--signature [env arity] - (if (> arity 1) - (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec arity) field-sig)) ")" - -return) - (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) ")" - -return))) - -(defn ^:private init-function [^MethodVisitor method-writer arity closure-length] - (if (= 1 arity) - (doto method-writer - (.visitLdcInsn (int 0)) - (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")) - (doto method-writer - (.visitVarInsn Opcodes/ILOAD (inc closure-length)) - (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")))) - -(defn ^:private add-lambda- [^ClassWriter class class-name arity env] - (let [closure-length (&/|length env)] - (doto (.visitMethod class Opcodes/ACC_PUBLIC "" (lambda--signature env arity) nil nil) - (.visitCode) - ;; Do normal object initialization - (.visitVarInsn Opcodes/ALOAD 0) - (init-function arity closure-length) - ;; Add all of the closure variables - (-> (put-field! class-name (str &&/closure-prefix ?captured-id) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD (inc ?captured-id))) - (->> (|let [[?name [_ (&o/$captured _ ?captured-id ?source)]] ?name+?captured]) - (doseq [?name+?captured (&/->seq env)]))) - ;; Add all the partial arguments - (-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD partial-register)) - (->> (|let [partial-register (+ (inc idx*) (inc closure-length))]) - (dotimes [idx* (dec arity)]))) - ;; Finish - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)))) - -(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)] - (defn ^:private add-lambda-impl [^ClassWriter class class-name compile arity impl-body] - (let [$begin (new Label)] - (&/with-writer (doto (.visitMethod class impl-flags "impl" (lambda-impl-signature arity) nil nil) - (.visitCode) - (.visitLabel $begin)) - (|do [^MethodVisitor *writer* &/get-writer - ret (compile $begin impl-body) - :let [_ (doto *writer* - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return ret)))))) - -(defn ^:private instance-closure [compile lambda-class arity closed-over] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW lambda-class) - (.visitInsn Opcodes/DUP))] - _ (&/map% (fn [?name+?captured] - (|case ?name+?captured - [?name [_ (&o/$captured _ _ ?source)]] - (compile nil ?source))) - closed-over) - :let [_ (when (> arity 1) - (doto *writer* - (.visitLdcInsn (int 0)) - (fill-nulls! (dec arity))))] - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" (lambda--signature closed-over arity))]] - (return nil))) - -(defn ^:private add-lambda-reset [^ClassWriter class-writer class-name arity env] - (if (> arity 1) - (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) - (.visitCode) - (.visitTypeInsn Opcodes/NEW class-name) - (.visitInsn Opcodes/DUP) - (-> (get-field! class-name (str &&/closure-prefix cidx)) - (->> (dotimes [cidx (&/|length env)]))) - (.visitLdcInsn (int 0)) - (fill-nulls! (dec arity)) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env arity)) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))) - -(defn ^:private add-lambda-apply-n [^ClassWriter class-writer +degree+ class-name arity env compile impl-body] - (if (> arity 1) - (let [num-partials (dec arity) - $default (new Label) - $labels* (map (fn [_] (new Label)) (repeat num-partials nil)) - $labels (vec (concat $labels* (list $default))) - $end (new Label) - method-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature +degree+) nil nil) - frame-locals (to-array (list class-name "java/lang/Object" "java/lang/Object")) - frame-stack (to-array [Opcodes/INTEGER]) - arity-over-extent (- arity +degree+)] - (do (doto method-writer - (.visitCode) - get-num-partials! - (.visitTableSwitchInsn 0 (dec num-partials) $default (into-array Label $labels*)) - ;; (< stage (- arity +degree+)) - (-> (doto (.visitLabel $label) - (.visitTypeInsn Opcodes/NEW class-name) - (.visitInsn Opcodes/DUP) - (-> (get-field! class-name (str &&/closure-prefix cidx)) - (->> (dotimes [cidx (&/|length env)]))) - get-num-partials! - (inc-int! +degree+) - (-> (get-field! class-name (str &&/partial-prefix idx)) - (->> (dotimes [idx stage]))) - (consecutive-args 1 +degree+) - (fill-nulls! (- (- num-partials +degree+) stage)) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env arity)) - (.visitJumpInsn Opcodes/GOTO $end)) - (->> (cond (= stage arity-over-extent) - (doto method-writer - (.visitLabel $label) - (.visitVarInsn Opcodes/ALOAD 0) - (-> (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) - (->> (when (not= 0 stage)))) - (-> (get-field! class-name (str &&/partial-prefix idx)) - (->> (dotimes [idx stage]))) - (consecutive-args 1 +degree+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) - (.visitJumpInsn Opcodes/GOTO $end)) - - (> stage arity-over-extent) - (let [args-to-completion (- arity stage) - args-left (- +degree+ args-to-completion)] - (doto method-writer - (.visitLabel $label) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) - (-> (get-field! class-name (str &&/partial-prefix idx)) - (->> (dotimes [idx stage]))) - (consecutive-args 1 args-to-completion) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) - (consecutive-applys (+ 1 args-to-completion) args-left) - (.visitJumpInsn Opcodes/GOTO $end))) - - :else) - (doseq [[stage $label] (map vector (range arity) $labels)]))) - (.visitLabel $end) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - (return nil))) - (let [$begin (new Label)] - (&/with-writer (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil) - (.visitCode) - (.visitLabel $begin)) - (|do [^MethodVisitor *writer* &/get-writer - ret (compile $begin impl-body) - :let [_ (doto *writer* - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return ret)))) - )) - -;; [Exports] -(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] - (defn compile-function [compile ?prev-writer arity ?scope ?env ?body] - (|do [[file-name _ _] &/cursor - :let [??scope (&/|reverse ?scope) - name (&host/location (&/|tail ??scope)) - class-name (str (&host/->module-class (&/|head ??scope)) "/" name) - [^ClassWriter =class save?] (|case ?prev-writer - (&/$Some _writer) - (&/T [_writer false]) - - (&/$None) - (&/T [(doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version lambda-flags - class-name nil &&/function-class (into-array String []))) - true])) - _ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) &&/arity-field "I" nil (int arity)) - (doto (.visitEnd))) - (-> (doto (.visitField datum-flags captured-name field-sig nil nil) - (.visitEnd)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (|case ?name+?captured - [?name [_ (&o/$captured _ ?captured-id ?source)]]) - (doseq [?name+?captured (&/->seq ?env)]))) - (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil) - (doto (.visitEnd)) - (->> (dotimes [idx (dec arity)]))) - (-> (.visitSource file-name nil) - (when save?)) - (add-lambda- class-name arity ?env) - (add-lambda-reset class-name arity ?env) - )] - _ (if (> arity 1) - (add-lambda-impl =class class-name compile arity ?body) - (return nil)) - _ (&/map% #(add-lambda-apply-n =class % class-name arity ?env compile ?body) - (&/|range* 1 (min arity &&/num-apply-variants))) - :let [_ (.visitEnd =class)] - _ (if save? - (&&/save-class! name (.toByteArray =class)) - (return nil))] - (if save? - (instance-closure compile class-name arity ?env) - (return (instance-closure compile class-name arity ?env)))))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj deleted file mode 100644 index 5dc8becc0..000000000 --- a/src/lux/compiler/lux.clj +++ /dev/null @@ -1,498 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler.lux - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [host :as &host] - [optimizer :as &o]) - [lux.host.generics :as &host-generics] - (lux.analyser [base :as &a] - [module :as &a-module] - [meta :as &a-meta]) - (lux.compiler [base :as &&] - [lambda :as &&lambda])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor) - java.lang.reflect.Field)) - -;; [Exports] -(defn compile-bool [?value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] - (return nil))) - -(do-template [ ] - (defn [value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn ( value)) - (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str "(" ")" (&host-generics/->type-signature ))))]] - (return nil))) - - compile-nat "java/lang/Long" "J" long - compile-int "java/lang/Long" "J" long - compile-frac "java/lang/Long" "J" long - compile-real "java/lang/Double" "D" double - compile-char "java/lang/Character" "C" char - ) - -(defn compile-text [?value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitLdcInsn *writer* ?value)]] - (return nil))) - -(defn compile-tuple [compile ?elems] - (|do [^MethodVisitor *writer* &/get-writer - :let [num-elems (&/|length ?elems)]] - (|case num-elems - 0 - (|do [:let [_ (.visitLdcInsn *writer* &/unit-tag)]] - (return nil)) - - 1 - (compile (&/|head ?elems)) - - _ - (|do [:let [_ (doto *writer* - (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] - _ (&/map2% (fn [idx elem] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret))) - (&/|range num-elems) ?elems)] - (return nil))))) - -(defn compile-variant [compile tag tail? value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitLdcInsn *writer* (int tag)) - _ (if tail? - (.visitLdcInsn *writer* "") - (.visitInsn *writer* Opcodes/ACONST_NULL))] - _ (compile value) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")]] - (return nil))) - -(defn compile-local [compile ?idx] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] - (return nil))) - -(defn compile-captured [compile ?scope ?captured-id ?source] - (|do [:let [??scope (&/|reverse ?scope)] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD - (str (&host/->module-class (&/|head ??scope)) "/" (&host/location (&/|tail ??scope))) - (str &&/closure-prefix ?captured-id) - "Ljava/lang/Object;"))]] - (return nil))) - -(defn compile-global [compile ?owner-class ?name] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&host/def-name ?name)) &/value-field "Ljava/lang/Object;")]] - (return nil))) - -(defn ^:private compile-apply* [compile ?args] - (|do [^MethodVisitor *writer* &/get-writer - _ (&/map% (fn [?args] - (|do [:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST &&/function-class)] - _ (&/map% compile ?args) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (&/|length ?args)))]] - (return nil))) - (&/|partition &&/num-apply-variants ?args))] - (return nil))) - -(defn compile-apply [compile ?fn ?args] - (|case ?fn - [_ (&o/$var (&/$Global ?module ?name))] - (|do [[_ [_ _ func-obj]] (&a-module/find-def ?module ?name) - class-loader &/loader - :let [func-class (class func-obj) - func-arity (.get ^Field (.getDeclaredField func-class &&/arity-field) nil) - func-partials (.get ^Field (.getDeclaredField (Class/forName "lux.Function" true class-loader) &&/partials-field) func-obj) - num-args (&/|length ?args) - func-class-name (->> func-class .getName &host-generics/->bytecode-class-name)]] - (if (and (= 0 func-partials) - (>= num-args func-arity)) - (|do [_ (compile ?fn) - ^MethodVisitor *writer* &/get-writer - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST func-class-name)] - _ (&/map% compile (&/|take func-arity ?args)) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL func-class-name (if (= 1 func-arity) &&/apply-method "impl") (&&/apply-signature func-arity))] - _ (if (= num-args func-arity) - (return nil) - (compile-apply* compile (&/|drop func-arity ?args)))] - (return nil)) - (|do [_ (compile ?fn)] - (compile-apply* compile ?args)))) - - _ - (|do [_ (compile ?fn)] - (compile-apply* compile ?args)) - )) - -(defn compile-loop [compile-expression register-offset inits body] - (|do [^MethodVisitor *writer* &/get-writer - :let [idxs+inits (&/zip2 (&/|range* 0 (dec (&/|length inits))) - inits)] - _ (&/map% (fn [idx+_init] - (|do [:let [[idx _init] idx+_init - idx+ (+ register-offset idx)] - _ (compile-expression nil _init) - :let [_ (.visitVarInsn *writer* Opcodes/ASTORE idx+)]] - (return nil))) - idxs+inits) - :let [$begin (new Label) - _ (.visitLabel *writer* $begin)]] - (compile-expression $begin body) - )) - -(defn compile-iter [compile $begin register-offset ?args] - (|do [^MethodVisitor *writer* &/get-writer - :let [idxs+args (&/zip2 (&/|range* 0 (dec (&/|length ?args))) - ?args)] - _ (&/map% (fn [idx+?arg] - (|do [:let [[idx ?arg] idx+?arg - idx+ (+ register-offset idx) - already-set? (|case ?arg - [_ (&o/$var (&/$Local l-idx))] - (= idx+ l-idx) - - _ - false)]] - (if already-set? - (return nil) - (compile ?arg)))) - idxs+args) - _ (&/map% (fn [idx+?arg] - (|do [:let [[idx ?arg] idx+?arg - idx+ (+ register-offset idx) - already-set? (|case ?arg - [_ (&o/$var (&/$Local l-idx))] - (= idx+ l-idx) - - _ - false)] - :let [_ (when (not already-set?) - (.visitVarInsn *writer* Opcodes/ASTORE idx+))]] - (return nil))) - (&/|reverse idxs+args)) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]] - (return nil))) - -(defn compile-let [compile _value _register _body] - (|do [^MethodVisitor *writer* &/get-writer - _ (compile _value) - :let [_ (.visitVarInsn *writer* Opcodes/ASTORE _register)] - _ (compile _body)] - (return nil))) - -(defn compile-record-get [compile _value _path] - (|do [^MethodVisitor *writer* &/get-writer - _ (compile _value) - :let [_ (&/|map (fn [step] - (|let [[idx tail?] step] - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int idx)) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" - (if tail? "product_getRight" "product_getLeft") - "([Ljava/lang/Object;I)Ljava/lang/Object;")))) - _path)]] - (return nil))) - -(defn compile-if [compile _test _then _else] - (|do [^MethodVisitor *writer* &/get-writer - _ (compile _test) - :let [$else (new Label) - $end (new Label) - _ (doto *writer* - &&/unwrap-boolean - (.visitJumpInsn Opcodes/IFEQ $else))] - _ (compile _then) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] - :let [_ (.visitLabel *writer* $else)] - _ (compile _else) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end) - _ (.visitLabel *writer* $end)]] - (return nil))) - -(defn ^:private de-ann [optim] - (|case optim - [_ (&o/$ann value-expr _)] - value-expr - - _ - optim)) - -(defn ^:private throwable->text [^Throwable t] - (let [base (->> t - .getStackTrace - (map str) - (cons (.getMessage t)) - (interpose "\n") - (apply str))] - (if-let [cause (.getCause t)] - (str base "\n\n" "Caused by: " (throwable->text cause)) - base))) - -(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] - (defn compile-def [compile ?name ?body ?meta] - (|do [module-name &/get-module-name - class-loader &/loader] - (|case (&a-meta/meta-get &a-meta/alias-tag ?meta) - (&/$Some (&/$IdentM [r-module r-name])) - (if (= 1 (&/|length ?meta)) - (|do [:let [current-class (&host-generics/->class-name (str (&host/->module-class r-module) "/" (&host/def-name r-name))) - def-class (&&/load-class! class-loader current-class) - def-type (&a-module/def-type r-module r-name) - def-meta ?meta - def-value (-> def-class (.getField &/value-field) (.get nil))] - _ (&/without-repl-closure - (&a-module/define module-name ?name def-type def-meta def-value))] - (return nil)) - (fail (str "[Compilation Error] Aliases cannot contain meta-data: " module-name ";" ?name))) - - (&/$Some _) - (fail "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.") - - _ - (|case (de-ann ?body) - [_ (&o/$function _ _ __scope _ _)] - (|let [[_ (&o/$function _ _arity _scope _captured ?body+)] (&o/shift-function-body (&/|tail __scope) __scope - false - (de-ann ?body))] - (|do [:let [=value-type (&a/expr-type* ?body)] - [file-name _ _] &/cursor - :let [datum-sig "Ljava/lang/Object;" - def-name (&host/def-name ?name) - current-class (str (&host/->module-class module-name) "/" def-name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version class-flags - current-class nil &&/function-class (into-array String [])) - (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) - (doto (.visitEnd))) - (-> (.visitField field-flags &/value-field datum-sig nil nil) - (doto (.visitEnd))) - (.visitSource file-name nil))] - instancer (&&lambda/compile-function compile (&/$Some =class) _arity _scope _captured ?body+) - _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) - (|do [^MethodVisitor **writer** &/get-writer - :let [_ (.visitCode **writer**)] - _ instancer - :let [_ (.visitTypeInsn **writer** Opcodes/CHECKCAST "java/lang/Object") - _ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] - :let [_ (doto **writer** - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd =class)] - _ (&&/save-class! def-name (.toByteArray =class)) - :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) - def-type (&a/expr-type* ?body) - is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) - (&/$Some (&/$BoolM true)) - true - - _ - false) - def-meta ?meta - def-value (-> def-class (.getField &/value-field) (.get nil))] - _ (&/without-repl-closure - (&a-module/define module-name ?name def-type def-meta def-value)) - _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)]) - [true (&/$Some (&/$ListM tags*))] - (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta) - (&/$Some _) - true - - _ - false)] - tags (&/map% (fn [tag*] - (|case tag* - (&/$TextM tag) - (return tag) - - _ - (fail "[Compiler Error] Incorrect format for tags."))) - tags*) - _ (&a-module/declare-tags module-name tags was-exported? def-value)] - (return nil)) - - [false (&/$Some _)] - (fail "[Compiler Error] Can't define tags for non-type.") - - [true (&/$Some _)] - (fail "[Compiler Error] Incorrect format for tags.") - - [_ (&/$None)] - (return nil)) - :let [_ (println 'DEF (str module-name ";" ?name))]] - (return nil))) - - _ - (|do [:let [=value-type (&a/expr-type* ?body)] - [file-name _ _] &/cursor - :let [datum-sig "Ljava/lang/Object;" - def-name (&host/def-name ?name) - current-class (str (&host/->module-class module-name) "/" def-name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version class-flags - current-class nil "java/lang/Object" (into-array String [])) - (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) - (doto (.visitEnd))) - (-> (.visitField field-flags &/value-field datum-sig nil nil) - (doto (.visitEnd))) - (.visitSource file-name nil))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) - (|do [^MethodVisitor **writer** &/get-writer - :let [_ (.visitCode **writer**)] - _ (compile nil ?body) - :let [_ (.visitTypeInsn **writer** Opcodes/CHECKCAST "java/lang/Object") - _ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] - :let [_ (doto **writer** - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd =class)] - _ (&&/save-class! def-name (.toByteArray =class)) - :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) - def-type (&a/expr-type* ?body) - is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) - (&/$Some (&/$BoolM true)) - true - - _ - false) - def-meta ?meta] - def-value (try (return (-> def-class (.getField &/value-field) (.get nil))) - (catch Throwable t - (&/assert! false (throwable->text t)))) - _ (&/without-repl-closure - (&a-module/define module-name ?name def-type def-meta def-value)) - _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)]) - [true (&/$Some (&/$ListM tags*))] - (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta) - (&/$Some _) - true - - _ - false)] - tags (&/map% (fn [tag*] - (|case tag* - (&/$TextM tag) - (return tag) - - _ - (fail "[Compiler Error] Incorrect format for tags."))) - tags*) - _ (&a-module/declare-tags module-name tags was-exported? def-value)] - (return nil)) - - [false (&/$Some _)] - (fail "[Compiler Error] Can't define tags for non-type.") - - [true (&/$Some _)] - (fail "[Compiler Error] Incorrect format for tags.") - - [_ (&/$None)] - (return nil)) - :let [_ (println 'DEF (str module-name ";" ?name))]] - (return nil))) - )))) - -(defn compile-program [compile ?body] - (|do [module-name &/get-module-name - ^ClassWriter *writer* &/get-writer] - (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) - (.visitCode)) - (|do [^MethodVisitor main-writer &/get-writer - :let [$loop (new Label) - $end (new Label) - _ (doto main-writer - ;; Tail: Begin - (.visitLdcInsn (->> #'&/$Nil meta ::&/idx int)) ;; I - (.visitInsn Opcodes/ACONST_NULL) ;; I? - (.visitLdcInsn &/unit-tag) ;; I?U - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; V - ;; Tail: End - ;; Size: Begin - (.visitVarInsn Opcodes/ALOAD 0) ;; VA - (.visitInsn Opcodes/ARRAYLENGTH) ;; VI - ;; Size: End - ;; Loop: Begin - (.visitLabel $loop) - (.visitLdcInsn (int 1)) ;; VII - (.visitInsn Opcodes/ISUB) ;; VI - (.visitInsn Opcodes/DUP) ;; VII - (.visitJumpInsn Opcodes/IFLT $end) ;; VI - ;; Head: Begin - (.visitInsn Opcodes/DUP) ;; VII - (.visitVarInsn Opcodes/ALOAD 0) ;; VIIA - (.visitInsn Opcodes/SWAP) ;; VIAI - (.visitInsn Opcodes/AALOAD) ;; VIO - (.visitInsn Opcodes/SWAP) ;; VOI - (.visitInsn Opcodes/DUP_X2) ;; IVOI - (.visitInsn Opcodes/POP) ;; IVO - ;; Head: End - ;; Tuple: Begin - (.visitLdcInsn (int 2)) ;; IVOS - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; IVO2 - (.visitInsn Opcodes/DUP_X1) ;; IV2O2 - (.visitInsn Opcodes/SWAP) ;; IV22O - (.visitLdcInsn (int 0)) ;; IV22OI - (.visitInsn Opcodes/SWAP) ;; IV22IO - (.visitInsn Opcodes/AASTORE) ;; IV2 - (.visitInsn Opcodes/DUP_X1) ;; I2V2 - (.visitInsn Opcodes/SWAP) ;; I22V - (.visitLdcInsn (int 1)) ;; I22VI - (.visitInsn Opcodes/SWAP) ;; I22IV - (.visitInsn Opcodes/AASTORE) ;; I2 - ;; Tuple: End - ;; Cons: Begin - (.visitLdcInsn (->> #'&/$Cons meta ::&/idx int)) ;; I2I - (.visitLdcInsn "") ;; I2I? - (.visitInsn Opcodes/DUP2_X1) ;; II?2I? - (.visitInsn Opcodes/POP2) ;; II?2 - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; IV - ;; Cons: End - (.visitInsn Opcodes/SWAP) ;; VI - (.visitJumpInsn Opcodes/GOTO $loop) - ;; Loop: End - (.visitLabel $end) ;; VI - (.visitInsn Opcodes/POP) ;; V - (.visitVarInsn Opcodes/ASTORE (int 0)) ;; - ) - ] - _ (compile ?body) - :let [_ (doto main-writer - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitInsn Opcodes/ACONST_NULL) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] - :let [_ (doto main-writer - (.visitInsn Opcodes/POP) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj deleted file mode 100644 index 03bc311f2..000000000 --- a/src/lux/compiler/module.clj +++ /dev/null @@ -1,28 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler.module - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail* |case]] - [type :as &type]) - [lux.analyser.module :as &module])) - -;; [Exports] -(def tag-groups - "(Lux (List (, Text (List Text))))" - (|do [module &/get-current-module] - (return (&/|map (fn [pair] - (|case pair - [name [tags exported? _]] - (&/T [name (&/|map (fn [tag] - (|let [[t-prefix t-name] tag] - t-name)) - tags)]))) - (&/get$ &module/$types module))) - )) diff --git a/src/lux/compiler/parallel.clj b/src/lux/compiler/parallel.clj deleted file mode 100644 index 8f6fee99d..000000000 --- a/src/lux/compiler/parallel.clj +++ /dev/null @@ -1,47 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler.parallel - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail* |case]]))) - -;; [Utils] -(def ^:private !state! (ref {})) - -(def ^:private get-compiler - (fn [compiler] - (return* compiler compiler))) - -;; [Exports] -(defn setup! - "Must always call this function before using parallel compilation to make sure that the state that is being tracked is in proper shape." - [] - (dosync (ref-set !state! {}))) - -(defn parallel-compilation [compile-module*] - (fn [module-name] - (|do [compiler get-compiler - :let [[task new?] (dosync (if-let [existing-task (get @!state! module-name)] - (&/T [existing-task false]) - (let [new-task (promise)] - (do (alter !state! assoc module-name new-task) - (&/T [new-task true]))))) - _ (when new? - (.start (new Thread - (fn [] - (let [out-str (with-out-str - (|case (&/run-state (compile-module* module-name) - compiler) - (&/$Right post-compiler _) - (deliver task (&/$Right post-compiler)) - - (&/$Left ?error) - (deliver task (&/$Left ?error))))] - (&/|log! out-str))))))]] - (return task)))) diff --git a/src/lux/host.clj b/src/lux/host.clj deleted file mode 100644 index 39e659964..000000000 --- a/src/lux/host.clj +++ /dev/null @@ -1,432 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.host - (:require (clojure [string :as string] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]] - [type :as &type]) - [lux.type.host :as &host-type] - [lux.host.generics :as &host-generics]) - (:import (java.lang.reflect Field Method Constructor Modifier Type - GenericArrayType ParameterizedType TypeVariable) - (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) - -;; [Constants] -(def function-class "lux.Function") -(def module-separator "/") -(def class-name-separator ".") -(def class-separator "/") -(def bytecode-version Opcodes/V1_6) - -;; [Resources] -(defn ^String ->module-class [old] - old) - -(def ->package ->module-class) - -(defn unfold-array [type] - "(-> Type (, Int Type))" - (|case type - (&/$HostT "#Array" (&/$Cons param (&/$Nil))) - (|let [[count inner] (unfold-array param)] - (&/T [(inc count) inner])) - - _ - (&/T [0 type]))) - -(let [ex-type-class (str "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";") - object-array (str "[" "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";")] - (defn ->java-sig [^objects type] - "(-> Type (Lux Text))" - (|case type - (&/$HostT ?name params) - (cond (= &host-type/array-data-tag ?name) (|do [:let [[level base] (unfold-array type)] - base-sig (|case base - (&/$HostT base-class _) - (return (&host-generics/->type-signature base-class)) - - _ - (->java-sig base))] - (return (str (->> (&/|repeat level "[") (&/fold str "")) - base-sig))) - (= &host-type/null-data-tag ?name) (return (&host-generics/->type-signature "java.lang.Object")) - :else (return (&host-generics/->type-signature ?name))) - - (&/$LambdaT _ _) - (return (&host-generics/->type-signature function-class)) - - (&/$UnitT) - (return "V") - - (&/$SumT _) - (return object-array) - - (&/$ProdT _) - (return object-array) - - (&/$NamedT ?name ?type) - (->java-sig ?type) - - (&/$AppT ?F ?A) - (|do [type* (&type/apply-type ?F ?A)] - (->java-sig type*)) - - (&/$ExT _) - (return ex-type-class) - - _ - (assert false (str '->java-sig " " (&type/show-type type))) - ))) - -(do-template [ ] - (defn [class-loader target field] - (|let [target-class (Class/forName target true class-loader)] - (if-let [^Type gtype (first (for [^Field =field (seq (.getDeclaredFields target-class)) - :when (and (.equals ^Object field (.getName =field)) - (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] - (.getGenericType =field)))] - (|let [gvars (->> target-class .getTypeParameters seq &/->list)] - (return (&/T [gvars gtype]))) - (&/fail-with-loc (str "[Host Error] Field does not exist: " target "." field))))) - - lookup-static-field true - lookup-field false - ) - -(do-template [ ] - (defn [class-loader target method-name args] - (|let [target-class (Class/forName target true class-loader)] - (if-let [[^Method method ^Class declarer] (first (for [^Method =method (.getDeclaredMethods target-class) - :when (and (.equals ^Object method-name (.getName =method)) - (.equals ^Object (Modifier/isStatic (.getModifiers =method))) - (let [param-types (&/->list (seq (.getParameterTypes =method)))] - (and (= (&/|length args) (&/|length param-types)) - (&/fold2 #(and %1 (.equals ^Object %2 %3)) - true - args - (&/|map #(.getName ^Class %) param-types)))))] - [=method - (.getDeclaringClass =method)]))] - (if (= target-class declarer) - (|let [parent-gvars (->> target-class .getTypeParameters seq &/->list) - gvars (->> method .getTypeParameters seq &/->list) - gargs (->> method .getGenericParameterTypes seq &/->list) - _ (when (.getAnnotation method java.lang.Deprecated) - (println (str "[Host Warning] Deprecated method: " target "." method-name " " (->> args &/->seq print-str))))] - (return (&/T [(.getGenericReturnType method) - (->> method .getExceptionTypes &/->list (&/|map #(.getName ^Class %))) - parent-gvars - gvars - gargs]))) - (&/fail-with-loc (str "[Host Error] " " method " (pr-str method-name) " for " "(" (->> args (&/|interpose ", ") (&/fold str "")) ")" " belongs to parent " (.getName declarer) " instead of " target))) - (&/fail-with-loc (str "[Host Error] " " method does not exist: " target "." method-name " " "(" (->> args (&/|interpose ", ") (&/fold str "")) ")"))))) - - lookup-static-method true "Static" - lookup-virtual-method false "Virtual" - ) - -(defn lookup-constructor [class-loader target args] - (let [target-class (Class/forName target true class-loader)] - (if-let [^Constructor ctor (first (for [^Constructor =method (.getDeclaredConstructors target-class) - :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] - (and (= (&/|length args) (&/|length param-types)) - (&/fold2 #(and %1 (.equals ^Object %2 %3)) - true - args - (&/|map #(.getName ^Class %) param-types))))] - =method))] - (|let [gvars (->> target-class .getTypeParameters seq &/->list) - gargs (->> ctor .getGenericParameterTypes seq &/->list) - exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName ^Class %))) - _ (when (.getAnnotation ctor java.lang.Deprecated) - (println (str "[Host Warning] Deprecated constructor: " target " " (->> args &/->seq print-str))))] - (return (&/T [exs gvars gargs]))) - (&/fail-with-loc (str "[Host Error] Constructor does not exist: " target " " (->> args &/->seq print-str)))))) - -(defn abstract-methods [class-loader super-class] - "(-> ClassLoader SuperClassDecl (Lux (List (, Text (List Text)))))" - (|let [[super-name super-params] super-class] - (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName super-name true class-loader)) - :when (Modifier/isAbstract (.getModifiers =method))] - (&/T [(.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))])))))) - -(defn def-name [name] - (str (&/normalize-name name) "_" (Long/toUnsignedString (hash name)))) - -(defn location [scope] - (let [scope (&/$Cons (def-name (&/|head scope)) - (&/|map &/normalize-name (&/|tail scope)))] - (->> scope - (&/|interpose "$") - (&/fold str "")))) - -(defn primitive-jvm-type? [type] - (case type - ("boolean" "byte" "short" "int" "long" "float" "double" "char") - true - ;; else - false)) - -(defn dummy-value [^MethodVisitor writer class] - (|case class - (&/$GenericClass "boolean" (&/$Nil)) - (doto writer - (.visitLdcInsn false)) - - (&/$GenericClass "byte" (&/$Nil)) - (doto writer - (.visitLdcInsn (byte 0))) - - (&/$GenericClass "short" (&/$Nil)) - (doto writer - (.visitLdcInsn (short 0))) - - (&/$GenericClass "int" (&/$Nil)) - (doto writer - (.visitLdcInsn (int 0))) - - (&/$GenericClass "long" (&/$Nil)) - (doto writer - (.visitLdcInsn (long 0))) - - (&/$GenericClass "float" (&/$Nil)) - (doto writer - (.visitLdcInsn (float 0.0))) - - (&/$GenericClass "double" (&/$Nil)) - (doto writer - (.visitLdcInsn (double 0.0))) - - (&/$GenericClass "char" (&/$Nil)) - (doto writer - (.visitLdcInsn (char 0))) - - _ - (doto writer - (.visitInsn Opcodes/ACONST_NULL)))) - -(defn ^:private dummy-return [^MethodVisitor writer output] - (|case output - (&/$GenericClass "void" (&/$Nil)) - (.visitInsn writer Opcodes/RETURN) - - (&/$GenericClass "boolean" (&/$Nil)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "byte" (&/$Nil)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "short" (&/$Nil)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "int" (&/$Nil)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "long" (&/$Nil)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/LRETURN)) - - (&/$GenericClass "float" (&/$Nil)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/FRETURN)) - - (&/$GenericClass "double" (&/$Nil)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/DRETURN)) - - (&/$GenericClass "char" (&/$Nil)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/IRETURN)) - - _ - (doto writer - (dummy-value output) - (.visitInsn Opcodes/ARETURN)))) - -(defn ^:private ->dummy-type [real-name store-name gclass] - (|case gclass - (&/$GenericClass _name _params) - (if (= real-name _name) - (&/$GenericClass store-name (&/|map (partial ->dummy-type real-name store-name) _params)) - gclass) - - _ - gclass)) - -(def init-method-name "") - -(defn ^:private dummy-ctor [^MethodVisitor writer real-name store-name super-class ctor-args] - (|let [ctor-arg-types (->> ctor-args (&/|map (comp &host-generics/->type-signature (comp (partial ->dummy-type real-name store-name) &/|first))) (&/fold str ""))] - (doto writer - (.visitVarInsn Opcodes/ALOAD 0) - (-> (doto (dummy-value arg-type) - (-> (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name arg-type)) - (->> (when (not (primitive-jvm-type? arg-type)))))) - (->> (doseq [ctor-arg (&/->seq ctor-args) - :let [;; arg-term (&/|first ctor-arg) - arg-type (->dummy-type real-name store-name (&/|first ctor-arg))]]))) - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) init-method-name (str "(" ctor-arg-types ")V")) - (.visitInsn Opcodes/RETURN)))) - -(defn ^:private compile-dummy-method [^ClassWriter =class real-name store-name super-class method-def] - (|case method-def - (&/$ConstructorMethodSyntax =privacy-modifier ?strict =anns =gvars =exceptions =inputs =ctor-args body) - (|let [=output (&/$GenericClass "void" (&/|list)) - method-decl [init-method-name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] - [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] - (doto (.visitMethod =class Opcodes/ACC_PUBLIC - init-method-name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) - .visitCode - (dummy-ctor real-name store-name super-class =ctor-args) - (.visitMaxs 0 0) - (.visitEnd))) - - (&/$VirtualMethodSyntax =name =privacy-modifier =final? ?strict =anns =gvars =exceptions =inputs =output body) - (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] - [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC - (if =final? Opcodes/ACC_FINAL 0)) - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) - .visitCode - (dummy-return =output) - (.visitMaxs 0 0) - (.visitEnd))) - - (&/$OverridenMethodSyntax =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) - (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] - [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] - (doto (.visitMethod =class Opcodes/ACC_PUBLIC - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) - .visitCode - (dummy-return =output) - (.visitMaxs 0 0) - (.visitEnd))) - - (&/$StaticMethodSyntax =name =privacy-modifier ?strict =anns =gvars =exceptions =inputs =output body) - (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] - [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) - .visitCode - (dummy-return =output) - (.visitMaxs 0 0) - (.visitEnd))) - - (&/$AbstractMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) - (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] - [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) - (.visitEnd))) - - (&/$NativeMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) - (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] - [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE) - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) - (.visitEnd))) - - _ - (assert false (println-str 'compile-dummy-method (&/adt->text method-def))) - )) - -(defn privacy-modifier->flag [privacy-modifier] - "(-> PrivacyModifier Int)" - (|case privacy-modifier - (&/$PublicPM) Opcodes/ACC_PUBLIC - (&/$PrivatePM) Opcodes/ACC_PRIVATE - (&/$ProtectedPM) Opcodes/ACC_PROTECTED - (&/$DefaultPM) 0 - )) - -(defn state-modifier->flag [state-modifier] - "(-> StateModifier Int)" - (|case state-modifier - (&/$DefaultSM) 0 - (&/$VolatileSM) Opcodes/ACC_VOLATILE - (&/$FinalSM) Opcodes/ACC_FINAL)) - -(defn inheritance-modifier->flag [inheritance-modifier] - "(-> InheritanceModifier Int)" - (|case inheritance-modifier - (&/$DefaultIM) 0 - (&/$AbstractIM) Opcodes/ACC_ABSTRACT - (&/$FinalIM) Opcodes/ACC_FINAL)) - -(defn use-dummy-class [class-decl super-class interfaces ctor-args fields methods] - (|do [module &/get-module-name - :let [[?name ?params] class-decl - dummy-name ?name;; (str ?name "__DUMMY__") - dummy-full-name (str module "/" dummy-name) - real-name (str (&host-generics/->class-name module) "." ?name) - store-name (str (&host-generics/->class-name module) "." dummy-name) - class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons super-class interfaces)) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - dummy-full-name - (if (= "" class-signature) nil class-signature) - (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) - (->> interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))) - _ (&/|map (fn [field] - (|case field - (&/$ConstantFieldAnalysis =name =anns =type ?value) - (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) =name - (&host-generics/gclass->simple-signature =type) - (&host-generics/gclass->signature =type) - nil) - (.visitEnd)) - - (&/$VariableFieldAnalysis =name =privacy-modifier =state-modifier =anns =type) - (doto (.visitField =class (+ Opcodes/ACC_PUBLIC (state-modifier->flag =state-modifier)) =name - (&host-generics/gclass->simple-signature =type) - (&host-generics/gclass->signature =type) - nil) - (.visitEnd)) - )) - fields) - _ (&/|map (partial compile-dummy-method =class real-name store-name super-class) methods) - bytecode (.toByteArray (doto =class .visitEnd))] - ^ClassLoader loader &/loader - !classes &/classes - :let [_ (swap! !classes assoc store-name bytecode) - _ (.loadClass loader store-name)] - _ (&/push-dummy-name real-name store-name)] - (return nil))) diff --git a/src/lux/host/generics.clj b/src/lux/host/generics.clj deleted file mode 100644 index cfd0d2d54..000000000 --- a/src/lux/host/generics.clj +++ /dev/null @@ -1,205 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.host.generics - (:require (clojure [string :as string] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]])) - (:import java.util.regex.Pattern)) - -(declare gclass->signature) - -(do-template [ ] - (let [regex (-> Pattern/quote re-pattern)] - (defn [old] - (string/replace old regex ))) - - ;; ->class - ^String ->bytecode-class-name "." "/" - ;; ->class-name - ^String ->class-name "/" "." - ) - -;; ->type-signature -(defn ->type-signature [class] - (case class - "void" "V" - "boolean" "Z" - "byte" "B" - "short" "S" - "int" "I" - "long" "J" - "float" "F" - "double" "D" - "char" "C" - ;; else - (let [class* (->bytecode-class-name class)] - (if (.startsWith class* "[") - class* - (str "L" class* ";"))) - )) - -(defn super-class-name [super] - "(-> GenericSuperClassDecl Text)" - (|let [[super-name super-params] super] - super-name)) - -(defn formal-type-parameter->signature [param] - (|let [[pname pbounds] param] - (|case pbounds - (&/$Nil) - pname - - _ - (->> pbounds - (&/|map (fn [pbound] (str ": " (gclass->signature pbound)))) - (&/|interpose " ") - (str pname " ")) - ))) - -(defn formal-type-parameters->signature [params] - (if (&/|empty? params) - "" - (str "<" (->> params (&/|map formal-type-parameter->signature) (&/|interpose " ") (&/fold str "")) ">"))) - -(defn gclass->signature [super] - "(-> GenericClass Text)" - (|case super - (&/$GenericTypeVar name) - (str "T" name ";") - - (&/$GenericWildcard (&/$None)) - "*" - - (&/$GenericWildcard (&/$Some [(&/$UpperBound) ?bound])) - (str "+" (gclass->signature ?bound)) - - (&/$GenericWildcard (&/$Some [(&/$LowerBound) ?bound])) - (str "-" (gclass->signature ?bound)) - - (&/$GenericClass ^String name params) - (case name - "void" "V" - "boolean" "Z" - "byte" "B" - "short" "S" - "int" "I" - "long" "J" - "float" "F" - "double" "D" - "char" "C" - ;; else - (if (.startsWith name "[") - name - (let [params* (if (&/|empty? params) - "" - (str "<" (->> params (&/|map gclass->signature) (&/|interpose "") (&/fold str "")) ">"))] - (str "L" (->bytecode-class-name name) params* ";")))) - - (&/$GenericArray param) - (str "[" (gclass->signature param)))) - -(defn gsuper-decl->signature [super] - "(-> GenericSuperClassDecl Text)" - (|let [[super-name super-params] super - params* (if (&/|empty? super-params) - "" - (str "<" (->> super-params (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")) ">"))] - (str "L" (->bytecode-class-name super-name) params* ";"))) - -(defn gclass-decl->signature [class-decl supers] - "(-> GenericClassDecl (List GenericSuperClassDecl) Text)" - (|let [[class-name class-vars] class-decl - vars-section (formal-type-parameters->signature class-vars) - super-section (->> (&/|map gsuper-decl->signature supers) (&/|interpose " ") (&/fold str ""))] - (str vars-section super-section))) - -(let [object-simple-signature (->type-signature "java.lang.Object")] - (defn gclass->simple-signature [gclass] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericTypeVar name) - object-simple-signature - - (&/$GenericWildcard _) - object-simple-signature - - (&/$GenericClass name params) - (->type-signature name) - - (&/$GenericArray param) - (str "[" (gclass->simple-signature param)) - - _ - (assert false (str 'gclass->simple-signature " " (&/adt->text gclass)))))) - -(defn gclass->class-name [gclass] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericTypeVar name) - (->bytecode-class-name "java.lang.Object") - - (&/$GenericWildcard _) - (->bytecode-class-name "java.lang.Object") - - (&/$GenericClass name params) - (->bytecode-class-name name) - - (&/$GenericArray param) - (str "[" (gclass->class-name param)) - - _ - (assert false (str 'gclass->class-name " " (&/adt->text gclass))))) - -(let [object-bc-name (->bytecode-class-name "java.lang.Object")] - (defn gclass->bytecode-class-name* [gclass type-env] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericTypeVar name) - object-bc-name - - (&/$GenericWildcard _) - object-bc-name - - (&/$GenericClass name params) - ;; When referring to type-parameters during class or method - ;; definition, a type-environment is set for storing the names - ;; of such parameters. - ;; When a "class" shows up with the name of one of those - ;; parameters, it must be detected, and the bytecode class-name - ;; must correspond to Object's. - (if (&/|get name type-env) - object-bc-name - (->bytecode-class-name name)) - - (&/$GenericArray param) - (assert false "gclass->bytecode-class-name* doesn't work on arrays.")))) - -(let [object-bc-name (->bytecode-class-name "java.lang.Object")] - (defn gclass->bytecode-class-name [gclass] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericTypeVar name) - object-bc-name - - (&/$GenericWildcard _) - object-bc-name - - (&/$GenericClass name params) - (->bytecode-class-name name) - - (&/$GenericArray param) - (assert false "gclass->bytecode-class-name doesn't work on arrays.")))) - -(defn method-signatures [method-decl] - (|let [[=name =anns =gvars =exceptions =inputs =output] method-decl - simple-signature (str "(" (&/fold str "" (&/|map gclass->simple-signature =inputs)) ")" (gclass->simple-signature =output)) - generic-signature (str (formal-type-parameters->signature =gvars) - "(" (&/fold str "" (&/|map gclass->signature =inputs)) ")" - (gclass->signature =output) - (->> =exceptions (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")))] - (&/T [simple-signature generic-signature]))) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj deleted file mode 100644 index f519aa563..000000000 --- a/src/lux/lexer.clj +++ /dev/null @@ -1,254 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.lexer - (:require (clojure [template :refer [do-template]] - [string :as string]) - (lux [base :as & :refer [defvariant |do return* return fail fail* |case]] - [reader :as &reader]) - [lux.analyser.module :as &module])) - -;; [Tags] -(defvariant - ("White_Space" 1) - ("Comment" 1) - ("Bool" 1) - ("Nat" 1) - ("Int" 1) - ("Frac" 1) - ("Real" 1) - ("Char" 1) - ("Text" 1) - ("Symbol" 1) - ("Tag" 1) - ("Open_Paren" 0) - ("Close_Paren" 0) - ("Open_Bracket" 0) - ("Close_Bracket" 0) - ("Open_Brace" 0) - ("Close_Brace" 0) - ) - -;; [Utils] -(defn ^:private escape-char [escaped] - "(-> Text (Lux Text))" - (cond (.equals ^Object escaped "\\t") (return "\t") - (.equals ^Object escaped "\\b") (return "\b") - (.equals ^Object escaped "\\n") (return "\n") - (.equals ^Object escaped "\\r") (return "\r") - (.equals ^Object escaped "\\f") (return "\f") - (.equals ^Object escaped "\\\"") (return "\"") - (.equals ^Object escaped "\\\\") (return "\\") - :else - (&/fail-with-loc (str "[Lexer Error] Unknown escape character: " escaped)))) - -(defn ^:private escape-char* [escaped] - "(-> Text Text)" - (cond (.equals ^Object escaped "\\t") "\t" - (.equals ^Object escaped "\\b") "\b" - (.equals ^Object escaped "\\n") "\n" - (.equals ^Object escaped "\\r") "\r" - (.equals ^Object escaped "\\f") "\f" - (.equals ^Object escaped "\\\"") "\"" - (.equals ^Object escaped "\\\\") "\\" - :else - (assert false (str "[Lexer Error] Unknown escape character: " escaped)))) - -(defn ^:private clean-line [^String raw-line] - "(-> Text Text)" - (let [line-length (.length raw-line) - buffer (new StringBuffer line-length)] - (loop [idx 0] - (if (< idx line-length) - (let [current-char (.charAt raw-line idx)] - (if (= \\ current-char) - (do (assert (< (+ 1 idx) line-length) (str "[Lexer Error] Text is too short for escaping: " raw-line " " idx)) - (case (.charAt raw-line (+ 1 idx)) - \t (do (.append buffer "\t") - (recur (+ 2 idx))) - \b (do (.append buffer "\b") - (recur (+ 2 idx))) - \n (do (.append buffer "\n") - (recur (+ 2 idx))) - \r (do (.append buffer "\r") - (recur (+ 2 idx))) - \f (do (.append buffer "\f") - (recur (+ 2 idx))) - \" (do (.append buffer "\"") - (recur (+ 2 idx))) - \\ (do (.append buffer "\\") - (recur (+ 2 idx))) - \u (do (assert (< (+ 5 idx) line-length) (str "[Lexer Error] Text is too short for unicode-escaping: " raw-line " " idx)) - (.append buffer (char (Integer/valueOf (.substring raw-line (+ 2 idx) (+ 6 idx)) 16))) - (recur (+ 6 idx))) - ;; else - (assert false (str "[Lexer Error] Invalid escaping syntax: " raw-line " " idx)))) - (do (.append buffer current-char) - (recur (+ 1 idx))))) - (.toString buffer))))) - -(defn ^:private lex-text-body [multi-line? offset] - (|do [[_ eol? ^String pre-quotes**] (&reader/read-regex #"^([^\"]*)") - ^String pre-quotes* (if multi-line? - (|do [:let [empty-line? (and eol? (= "" pre-quotes**))] - _ (&/assert! (or empty-line? - (>= (.length pre-quotes**) offset)) - "Each line of a multi-line text must have an appropriate offset!")] - (return (if empty-line? - "\n" - (str "\n" (.substring pre-quotes** offset))))) - (return pre-quotes**)) - [pre-quotes post-quotes] (if (.endsWith pre-quotes* "\\") - (if eol? - (&/fail-with-loc "[Lexer Error] Can't leave dangling back-slash \\") - (if (if-let [^String back-slashes (re-find #"\\+$" pre-quotes*)] - (odd? (.length back-slashes))) - (|do [[_ eol?* _] (&reader/read-regex #"^([\"])") - next-part (lex-text-body eol?* offset)] - (return (&/T [(.substring pre-quotes* 0 (dec (.length pre-quotes*))) - (str "\"" next-part)]))) - (|do [post-quotes* (lex-text-body false offset)] - (return (&/T [pre-quotes* post-quotes*]))))) - (if eol? - (|do [next-part (lex-text-body true offset)] - (return (&/T [pre-quotes* - next-part]))) - (return (&/T [pre-quotes* ""]))))] - (return (str (clean-line pre-quotes) post-quotes)))) - -(def lex-text - (|do [[meta _ _] (&reader/read-text "\"") - :let [[_ _ _column] meta] - token (lex-text-body false (inc _column)) - _ (&reader/read-text "\"")] - (return (&/T [meta ($Text token)])))) - -(def +ident-re+ - #"^([^0-9\[\]\{\}\(\)\s\"#;][^\[\]\{\}\(\)\s\"#;]*)") - -;; [Lexers] -(def ^:private lex-white-space - (|do [[meta _ white-space] (&reader/read-regex #"^(\s+|$)")] - (return (&/T [meta ($White_Space white-space)])))) - -(def ^:private lex-single-line-comment - (|do [_ (&reader/read-text "##") - [meta _ comment] (&reader/read-regex #"^(.*)$")] - (return (&/T [meta ($Comment comment)])))) - -(defn ^:private lex-multi-line-comment [_] - (|do [_ (&reader/read-text "#(") - [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex+ #"(?is)^(?!#\()((?!\)#).)*")] - (return (&/T [meta comment]))) - (|do [[meta pre] (&reader/read-regex+ #"(?is)^((?!#\().)*") - [_ ($Comment inner)] (lex-multi-line-comment nil) - [_ post] (&reader/read-regex+ #"(?is)^((?!\)#).)*")] - (return (&/T [meta (str pre "#(" inner ")#" post)]))))) - _ (&reader/read-text ")#")] - (return (&/T [meta ($Comment comment)])))) - -(def ^:private lex-comment - (&/try-all% (&/|list lex-single-line-comment - (lex-multi-line-comment nil)))) - -(do-template [ ] - (def - (|do [[meta _ token] (&reader/read-regex )] - (return (&/T [meta ( token)])))) - - lex-bool $Bool #"^(true|false)" - ) - -(do-template [ ] - (def - (|do [[meta _ token] (&reader/read-regex )] - (return (&/T [meta ( (string/replace token #",|_" ""))])))) - - lex-nat $Nat #"^\+(0|[1-9][0-9,_]*)" - lex-int $Int #"^-?(0|[1-9][0-9,_]*)" - lex-frac $Frac #"^(\.[0-9,_]+)" - lex-real $Real #"^-?(0\.[0-9,_]+|[1-9][0-9,_]*\.[0-9,_]+)(e-?[1-9][0-9,_]*)?" - ) - -(def lex-char - (|do [[meta _ _] (&reader/read-text "#\"") - token (&/try-all% (&/|list (|do [[_ _ escaped] (&reader/read-regex #"^(\\.)")] - (escape-char escaped)) - (|do [[_ _ ^String unicode] (&reader/read-regex #"^(\\u[0-9a-fA-F]{4})")] - (return (str (char (Integer/valueOf (.substring unicode 2) 16))))) - (|do [[_ _ char] (&reader/read-regex #"^(.)")] - (return char)))) - _ (&reader/read-text "\"")] - (return (&/T [meta ($Char token)])))) - -(def ^:private lex-ident - (&/try-all-% "[Reader Error]" - (&/|list (|do [[meta _ token] (&reader/read-regex +ident-re+) - [_ _ got-it?] (&reader/read-text? ";")] - (|case got-it? - (&/$Some _) - (|do [[_ _ local-token] (&reader/read-regex +ident-re+) - ? (&module/exists? token)] - (if ? - (return (&/T [meta (&/T [token local-token])])) - (|do [unaliased (&module/dealias token)] - (return (&/T [meta (&/T [unaliased local-token])]))))) - - (&/$None) - (return (&/T [meta (&/T ["" token])])))) - (|do [[meta _ _] (&reader/read-text ";;") - [_ _ token] (&reader/read-regex +ident-re+) - module-name &/get-module-name] - (return (&/T [meta (&/T [module-name token])]))) - (|do [[meta _ _] (&reader/read-text ";") - [_ _ token] (&reader/read-regex +ident-re+)] - (return (&/T [meta (&/T ["lux" token])]))) - ))) - -(def ^:private lex-symbol - (|do [[meta ident] lex-ident] - (return (&/T [meta ($Symbol ident)])))) - -(def ^:private lex-tag - (|do [[meta _ _] (&reader/read-text "#") - [_ ident] lex-ident] - (return (&/T [meta ($Tag ident)])))) - -(do-template [ ] - (def - (|do [[meta _ _] (&reader/read-text )] - (return (&/T [meta ])))) - - ^:private lex-open-paren "(" $Open_Paren - ^:private lex-close-paren ")" $Close_Paren - ^:private lex-open-bracket "[" $Open_Bracket - ^:private lex-close-bracket "]" $Close_Bracket - ^:private lex-open-brace "{" $Open_Brace - ^:private lex-close-brace "}" $Close_Brace - ) - -(def ^:private lex-delimiter - (&/try-all% (&/|list lex-open-paren - lex-close-paren - lex-open-bracket - lex-close-bracket - lex-open-brace - lex-close-brace))) - -;; [Exports] -(def lex - (&/try-all-% "[Reader Error]" - (&/|list lex-white-space - lex-comment - lex-bool - lex-nat - lex-real - lex-frac - lex-int - lex-char - lex-text - lex-symbol - lex-tag - lex-delimiter))) diff --git a/src/lux/lib/loader.clj b/src/lux/lib/loader.clj deleted file mode 100644 index e8310f9f0..000000000 --- a/src/lux/lib/loader.clj +++ /dev/null @@ -1,54 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.lib.loader - (:refer-clojure :exclude [load]) - (:require (lux [base :as & :refer [|let |do return fail return* fail* |case]])) - (:import (java.io InputStream - File - FileInputStream - ByteArrayInputStream - ByteArrayOutputStream) - java.util.jar.JarInputStream)) - -;; [Utils] -(defn ^:private fetch-libs [] - (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader) - (.getURLs) - seq - (map #(.getFile ^java.net.URL %)) - (filter #(.endsWith ^String % ".jar")) - (map #(new File ^String %)))) - -(let [init-capacity (* 100 1024) - buffer-size 1024] - (defn ^:private ^"[B" read-stream [^InputStream is] - (let [buffer (byte-array buffer-size)] - (with-open [os (new ByteArrayOutputStream init-capacity)] - (loop [bytes-read (.read is buffer 0 buffer-size)] - (when (not= -1 bytes-read) - (do (.write os buffer 0 bytes-read) - (recur (.read is buffer 0 buffer-size))))) - (.toByteArray os))))) - -(defn ^:private unpackage [^File lib-file] - (let [is (->> lib-file - (new FileInputStream) - (new JarInputStream))] - (loop [lib-data {} - entry (.getNextJarEntry is)] - (if entry - (if (.endsWith (.getName entry) ".lux") - (recur (assoc lib-data (.getName entry) (new String (read-stream is))) - (.getNextJarEntry is)) - (recur lib-data - (.getNextJarEntry is))) - lib-data)))) - -;; [Exports] -(defn load [] - (->> (fetch-libs) - (map unpackage) - (reduce merge {}))) diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj deleted file mode 100644 index 5c30dc44f..000000000 --- a/src/lux/optimizer.clj +++ /dev/null @@ -1,1202 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. -(ns lux.optimizer - (:require (lux [base :as & :refer [|let |do return fail return* fail* |case defvariant]]) - (lux.analyser [base :as &a] - [case :as &a-case]))) - -;; [Tags] -(defvariant - ;; These tags just have a one-to-one correspondence with Analysis data-structures. - ("bool" 1) - ("nat" 1) - ("int" 1) - ("frac" 1) - ("real" 1) - ("char" 1) - ("text" 1) - ("variant" 3) - ("tuple" 1) - ("apply" 2) - ("case" 2) - ("function" 5) - ("ann" 2) - ("var" 1) - ("captured" 3) - ("proc" 3) - - ;; These other tags represent higher-order constructs that manifest - ;; themselves as patterns in the code. - ;; Lux doesn't formally provide these features, but some macros - ;; expose ways to implement them in terms of the other (primitive) - ;; features. - ;; The optimizer looks for those usage patterns and transforms them - ;; into explicit constructs, which are then subject to specialized optimizations. - - ;; Loop scope, for doing loop inlining - ("loop" 3) ;; {register-offset Int, inits (List Optimized), body Optimized} - ;; This is loop iteration, as expected in imperative programming. - ("iter" 2) ;; {register-offset Int, vals (List Optimized)} - ;; This is a simple let-expression, as opposed to the more general pattern-matching. - ("let" 3) - ;; This is an access to a record's member. It can be multi-level: - ;; e.g. record.l1.l2.l3 - ;; The record-get token stores the path, for simpler compilation. - ("record-get" 2) - ;; Regular, run-of-the-mill if expressions. - ("if" 3) - ) - -;; [Utils] - -;; [[Pattern-Matching Traversal Optimization]] - -;; This represents an alternative way to view pattern-matching. -;; The PM that Lux provides has declarative semantics, with the user -;; specifying how his data is shaped, but not how to traverse it. -;; The optimizer's PM is operational in nature, and relies on -;; specifying a path of traversal, with a variety of operations that -;; can be done along the way. -;; The algorithm relies on looking at pattern-matching as traversing a -;; (possibly) branching path, where each step along the path -;; corresponds to a value, the ends of the path are the jumping-off -;; points for the bodies of branches, and branching decisions can be -;; backtracked, if they don't result in a valid jump. -(defvariant - ;; Throw away the current data-node (CDN). It's useless. - ("PopPM" 0) - ;; Store the CDN in a register. - ("BindPM" 1) - ;; Compare the CDN with a boolean value. - ("BoolPM" 1) - ;; Compare the CDN with a natural value. - ("NatPM" 1) - ;; Compare the CDN with an integer value. - ("IntPM" 1) - ;; Compare the CDN with a fractional value. - ("FracPM" 1) - ;; Compare the CDN with a real value. - ("RealPM" 1) - ;; Compare the CDN with a character value. - ("CharPM" 1) - ;; Compare the CDN with a text value. - ("TextPM" 1) - ;; Compare the CDN with a variant value. If valid, proceed to test - ;; the variant's inner value. - ("VariantPM" 1) - ;; Access a tuple value at a given index, for further examination. - ("TuplePM" 1) - ;; Creates an instance of the backtracking info, as a preparatory - ;; step to exploring one of the branching paths. - ("AltPM" 2) - ;; Allows to test the CDN, while keeping a copy of it for more - ;; tasting later on. - ;; If necessary when doing multiple tests on a single value, like - ;; when testing multiple parts of a tuple. - ("SeqPM" 2) - ;; This is the jumping-off point for the PM part, where the PM - ;; data-structure is thrown away and the program jumps to the - ;; branch's body. - ("ExecPM" 1)) - -(defn de-meta - "(-> Optimized Optimized)" - [optim] - (|let [[meta optim-] optim] - (|case optim- - ($variant idx is-last? value) - ($variant idx is-last? (de-meta value)) - - ($tuple elems) - ($tuple (&/|map de-meta elems)) - - ($case value [_pm _bodies]) - ($case (de-meta value) - (&/T [_pm (&/|map de-meta _bodies)])) - - ($function _register-offset arity scope captured body*) - ($function _register-offset - arity - scope - (&/|map (fn [capture] - (|let [[_name [_meta ($captured _scope _idx _source)]] capture] - (&/T [_name ($captured _scope _idx (de-meta _source))]))) - captured) - (de-meta body*)) - - ($ann value-expr type-expr) - (de-meta value-expr) - - ($apply func args) - ($apply (de-meta func) - (&/|map de-meta args)) - - ($captured scope idx source) - ($captured scope idx (de-meta source)) - - ($proc proc-ident args special-args) - ($proc proc-ident (&/|map de-meta args) special-args) - - ($loop _register-offset _inits _body) - ($loop _register-offset - (&/|map de-meta _inits) - (de-meta _body)) - - ($iter _iter-register-offset args) - ($iter _iter-register-offset - (&/|map de-meta args)) - - ($let _value _register _body) - ($let (de-meta _value) - _register - (de-meta _body)) - - ($record-get _value _path) - ($record-get (de-meta _value) - _path) - - ($if _test _then _else) - ($if (de-meta _test) - (de-meta _then) - (de-meta _else)) - - _ - optim- - ))) - -;; This function does a simple transformation from the declarative -;; model of PM of the analyser, to the operational model of PM of the -;; optimizer. -;; You may notice that all branches end in PopPM. -;; The reason is that testing does not immediately imply throwing away -;; the data to be tested, which is why a popping step must immediately follow. -(defn ^:private transform-pm* [test] - (|case test - (&a-case/$NoTestAC) - (&/|list $PopPM) - - (&a-case/$StoreTestAC _register) - (&/|list ($BindPM _register)) - - (&a-case/$BoolTestAC _value) - (&/|list ($BoolPM _value) - $PopPM) - - (&a-case/$NatTestAC _value) - (&/|list ($NatPM _value) - $PopPM) - - (&a-case/$IntTestAC _value) - (&/|list ($IntPM _value) - $PopPM) - - (&a-case/$FracTestAC _value) - (&/|list ($FracPM _value) - $PopPM) - - (&a-case/$RealTestAC _value) - (&/|list ($RealPM _value) - $PopPM) - - (&a-case/$CharTestAC _value) - (&/|list ($CharPM _value) - $PopPM) - - (&a-case/$TextTestAC _value) - (&/|list ($TextPM _value) - $PopPM) - - (&a-case/$VariantTestAC _idx _num-options _sub-test) - (&/|++ (&/|list ($VariantPM (if (= _idx (dec _num-options)) - (&/$Right _idx) - (&/$Left _idx)))) - (&/|++ (transform-pm* _sub-test) - (&/|list $PopPM))) - - (&a-case/$TupleTestAC _sub-tests) - (|case _sub-tests - ;; An empty tuple corresponds to unit, which can't be tested in - ;; any meaningful way, so it's just popped. - (&/$Nil) - (&/|list $PopPM) - - ;; A tuple of a single element is equivalent to the element - ;; itself, to the element's PM is generated. - (&/$Cons _only-test (&/$Nil)) - (transform-pm* _only-test) - - ;; Single tuple PM features the tests of each tuple member - ;; inlined, it's operational equivalent is interleaving the - ;; access to each tuple member, followed by the testing of said - ;; member. - ;; That is way each sequence of access+subtesting gets generated - ;; and later they all get concatenated. - _ - (|let [tuple-size (&/|length _sub-tests)] - (&/|++ (&/flat-map (fn [idx+test*] - (|let [[idx test*] idx+test*] - (&/$Cons ($TuplePM (if (< idx (dec tuple-size)) - (&/$Left idx) - (&/$Right idx))) - (transform-pm* test*)))) - (&/zip2 (&/|range tuple-size) - _sub-tests)) - (&/|list $PopPM)))))) - -;; It will be common for pattern-matching on a very nested -;; data-structure to require popping all the intermediate -;; data-structures that were visited once it's all done. -;; However, the PM infrastructure employs a single data-stack to keep -;; all data nodes in the trajectory, and that data-stack can just be -;; thrown again entirely, in just one step. -;; Because of that, any ending POPs prior to throwing away the -;; data-stack would be completely useless. -;; This function cleans them all up, to avoid wasteful computation later. -(defn ^:private clean-unnecessary-pops [steps] - (|case steps - (&/$Cons ($PopPM) _steps) - (clean-unnecessary-pops _steps) - - _ - steps)) - -;; This transforms a single branch of a PM tree into it's operational -;; equivalent, while also associating the PM of the branch with the -;; jump to the branch's body. -(defn ^:private transform-pm [test body-id] - (&/fold (fn [right left] ($SeqPM left right)) - ($ExecPM body-id) - (clean-unnecessary-pops (&/|reverse (transform-pm* test))))) - -(defn ^:private pattern->text [pattern] - (|case pattern - ($PopPM) - "$PopPM" - - ($BindPM _id) - (str "($BindPM " _id ")") - - ($BoolPM _value) - (str "($BoolPM " (pr-str _value) ")") - - ($NatPM _value) - (str "($NatPM " (pr-str _value) ")") - - ($IntPM _value) - (str "($IntPM " (pr-str _value) ")") - - ($FracPM _value) - (str "($FracPM " (pr-str _value) ")") - - ($RealPM _value) - (str "($RealPM " (pr-str _value) ")") - - ($CharPM _value) - (str "($CharPM " (pr-str _value) ")") - - ($TextPM _value) - (str "($TextPM " (pr-str _value) ")") - - ($TuplePM (&/$Left _idx)) - (str "($TuplePM L" _idx ")") - - ($TuplePM (&/$Right _idx)) - (str "($TuplePM R" _idx ")") - - ($VariantPM (&/$Left _idx)) - (str "($VariantPM L" _idx ")") - - ($VariantPM (&/$Right _idx)) - (str "($VariantPM R" _idx ")") - - ($SeqPM _left _right) - (str "($SeqPM " (pattern->text _left) " " (pattern->text _right) ")") - - ($ExecPM _idx) - (str "($ExecPM " _idx ")") - - ;; $AltPM is not considered because it's not supposed to be - ;; present anywhere at this point in time. - )) - -;; This function fuses together the paths of the PM traversal, adding -;; branching AltPMs where necessary, and fusing similar paths together -;; as much as possible, when early parts of them coincide. -;; The goal is to minimize rework as much as possible by sharing as -;; much of each path as possible. -(defn ^:private fuse-pms [pre post] - (|case (&/T [pre post]) - [($PopPM) ($PopPM)] - $PopPM - - [($BindPM _pre-var-id) ($BindPM _post-var-id)] - (if (= _pre-var-id _post-var-id) - ($BindPM _pre-var-id) - ($AltPM pre post)) - - [($BoolPM _pre-value) ($BoolPM _post-value)] - (if (= _pre-value _post-value) - ($BoolPM _pre-value) - ($AltPM pre post)) - - [($NatPM _pre-value) ($NatPM _post-value)] - (if (= _pre-value _post-value) - ($NatPM _pre-value) - ($AltPM pre post)) - - [($IntPM _pre-value) ($IntPM _post-value)] - (if (= _pre-value _post-value) - ($IntPM _pre-value) - ($AltPM pre post)) - - [($FracPM _pre-value) ($FracPM _post-value)] - (if (= _pre-value _post-value) - ($FracPM _pre-value) - ($AltPM pre post)) - - [($RealPM _pre-value) ($RealPM _post-value)] - (if (= _pre-value _post-value) - ($RealPM _pre-value) - ($AltPM pre post)) - - [($CharPM _pre-value) ($CharPM _post-value)] - (if (= _pre-value _post-value) - ($CharPM _pre-value) - ($AltPM pre post)) - - [($TextPM _pre-value) ($TextPM _post-value)] - (if (= _pre-value _post-value) - ($TextPM _pre-value) - ($AltPM pre post)) - - [($TuplePM (&/$Left _pre-idx)) ($TuplePM (&/$Left _post-idx))] - (if (= _pre-idx _post-idx) - ($TuplePM (&/$Left _pre-idx)) - ($AltPM pre post)) - - [($TuplePM (&/$Right _pre-idx)) ($TuplePM (&/$Right _post-idx))] - (if (= _pre-idx _post-idx) - ($TuplePM (&/$Right _pre-idx)) - ($AltPM pre post)) - - [($VariantPM (&/$Left _pre-idx)) ($VariantPM (&/$Left _post-idx))] - (if (= _pre-idx _post-idx) - ($VariantPM (&/$Left _pre-idx)) - ($AltPM pre post)) - - [($VariantPM (&/$Right _pre-idx)) ($VariantPM (&/$Right _post-idx))] - (if (= _pre-idx _post-idx) - ($VariantPM (&/$Right _pre-idx)) - ($AltPM pre post)) - - [($SeqPM _pre-pre _pre-post) ($SeqPM _post-pre _post-post)] - (|case (fuse-pms _pre-pre _post-pre) - ($AltPM _ _) - ($AltPM pre post) - - fused-pre - ($SeqPM fused-pre (fuse-pms _pre-post _post-post))) - - _ - ($AltPM pre post) - )) - -(defn ^:private pattern-vars [pattern] - (|case pattern - ($BindPM _id) - (&/|list (&/T [_id false])) - - ($SeqPM _left _right) - (&/|++ (pattern-vars _left) (pattern-vars _right)) - - _ - (&/|list) - - ;; $AltPM is not considered because it's not supposed to be - ;; present anywhere at this point in time. - )) - -(defn ^:private find-unused-vars [var-table body] - (|let [[meta body-] body] - (|case body- - ($var (&/$Local _idx)) - (&/|update _idx (fn [_] true) var-table) - - ($captured _scope _c-idx [_ ($var (&/$Local _idx))]) - (&/|update _idx (fn [_] true) var-table) - - ($variant _idx _is-last? _value) - (find-unused-vars var-table _value) - - ($tuple _elems) - (&/fold find-unused-vars var-table _elems) - - ($ann _value-expr _type-expr) - (find-unused-vars var-table _value-expr) - - ($apply _func _args) - (&/fold find-unused-vars - (find-unused-vars var-table _func) - _args) - - ($proc _proc-ident _args _special-args) - (&/fold find-unused-vars var-table _args) - - ($loop _register-offset _inits _body) - (&/|++ (&/fold find-unused-vars var-table _inits) - (find-unused-vars var-table _body)) - - ($iter _ _args) - (&/fold find-unused-vars var-table _args) - - ($let _value _register _body) - (-> var-table - (find-unused-vars _value) - (find-unused-vars _body)) - - ($record-get _value _path) - (find-unused-vars var-table _value) - - ($if _test _then _else) - (-> var-table - (find-unused-vars _test) - (find-unused-vars _then) - (find-unused-vars _else)) - - ($case _value [_pm _bodies]) - (&/fold find-unused-vars - (find-unused-vars var-table _value) - _bodies) - - ($function _ _ _ _captured _) - (->> _captured - (&/|map &/|second) - (&/fold find-unused-vars var-table)) - - _ - var-table - ))) - -(defn ^:private clean-unused-pattern-registers [var-table pattern] - (|case pattern - ($BindPM _idx) - (|let [_new-idx (&/|get _idx var-table)] - (cond (= _idx _new-idx) - pattern - - (>= _new-idx 0) - ($BindPM _new-idx) - - :else - $PopPM)) - - ($SeqPM _left _right) - ($SeqPM (clean-unused-pattern-registers var-table _left) - (clean-unused-pattern-registers var-table _right)) - - _ - pattern - - ;; $AltPM is not considered because it's not supposed to be - ;; present anywhere at this point in time. - )) - -;; This function assumes that the var-table has an ascending index -;; order. -;; For example: (2 3 4 5 6 7 8), instead of (8 7 6 5 4 3 2) -(defn ^:private adjust-register-indexes* [offset var-table] - (|case var-table - (&/$Nil) - (&/|list) - - (&/$Cons [_idx _used?] _tail) - (if _used? - (&/$Cons (&/T [_idx (- _idx offset)]) - (adjust-register-indexes* offset _tail)) - (&/$Cons (&/T [_idx -1]) - (adjust-register-indexes* (inc offset) _tail)) - ))) - -(defn ^:private adjust-register-indexes [var-table] - (adjust-register-indexes* 0 var-table)) - -(defn ^:private clean-unused-body-registers [var-table body] - (|let [[meta body-] body] - (|case body- - ($var (&/$Local _idx)) - (|let [new-idx (or (&/|get _idx var-table) - _idx)] - (&/T [meta ($var (&/$Local new-idx))])) - - ($captured _scope _c-idx [_sub-meta ($var (&/$Local _idx))]) - (|let [new-idx (or (&/|get _idx var-table) - _idx)] - (&/T [meta ($captured _scope _c-idx (&/T [_sub-meta ($var (&/$Local new-idx))]))])) - - ($variant _idx _is-last? _value) - (&/T [meta ($variant _idx _is-last? (clean-unused-body-registers var-table _value))]) - - ($tuple _elems) - (&/T [meta ($tuple (&/|map (partial clean-unused-body-registers var-table) - _elems))]) - - ($ann _value-expr _type-expr) - (&/T [meta ($ann (clean-unused-body-registers var-table _value-expr) _type-expr)]) - - ($apply _func _args) - (&/T [meta ($apply (clean-unused-body-registers var-table _func) - (&/|map (partial clean-unused-body-registers var-table) - _args))]) - - ($proc _proc-ident _args _special-args) - (&/T [meta ($proc _proc-ident - (&/|map (partial clean-unused-body-registers var-table) - _args) - _special-args)]) - - ($loop _register-offset _inits _body) - (&/T [meta ($loop _register-offset - (&/|map (partial clean-unused-body-registers var-table) - _inits) - (clean-unused-body-registers var-table _body))]) - - ($iter _iter-register-offset _args) - (&/T [meta ($iter _iter-register-offset - (&/|map (partial clean-unused-body-registers var-table) - _args))]) - - ($let _value _register _body) - (&/T [meta ($let (clean-unused-body-registers var-table _value) - _register - (clean-unused-body-registers var-table _body))]) - - ($record-get _value _path) - (&/T [meta ($record-get (clean-unused-body-registers var-table _value) - _path)]) - - ($if _test _then _else) - (&/T [meta ($if (clean-unused-body-registers var-table _test) - (clean-unused-body-registers var-table _then) - (clean-unused-body-registers var-table _else))]) - - ($case _value [_pm _bodies]) - (&/T [meta ($case (clean-unused-body-registers var-table _value) - (&/T [_pm - (&/|map (partial clean-unused-body-registers var-table) - _bodies)]))]) - - ($function _register-offset _arity _scope _captured _body) - (&/T [meta ($function _register-offset - _arity - _scope - (&/|map (fn [capture] - (|let [[_name __var] capture] - (&/T [_name (clean-unused-body-registers var-table __var)]))) - _captured) - _body)]) - - _ - body - ))) - -(defn ^:private simplify-pattern [pattern] - (|case pattern - ($SeqPM ($TuplePM _idx) ($SeqPM ($PopPM) pattern*)) - (simplify-pattern pattern*) - - ($SeqPM ($TuplePM _idx) _right) - (|case (simplify-pattern _right) - ($SeqPM ($PopPM) pattern*) - pattern* - - _right* - ($SeqPM ($TuplePM _idx) _right*)) - - ($SeqPM _left _right) - ($SeqPM _left (simplify-pattern _right)) - - _ - pattern)) - -(defn ^:private optimize-register-use [pattern body] - (|let [p-vars (pattern-vars pattern) - p-vars* (find-unused-vars p-vars body) - adjusted-vars (adjust-register-indexes p-vars*) - clean-pattern (clean-unused-pattern-registers adjusted-vars pattern) - simple-pattern (simplify-pattern clean-pattern) - clean-body (clean-unused-body-registers adjusted-vars body)] - (&/T [simple-pattern clean-body]))) - -;; This is the top-level function for optimizing PM, which transforms -;; each branch and then fuses them together. -(defn ^:private optimize-pm [branches] - (|let [;; branches (&/|reverse branches*) - pms+bodies (&/map2 (fn [branch _body-id] - (|let [[_pattern _body] branch] - (optimize-register-use (transform-pm _pattern _body-id) - _body))) - branches - (&/|range (&/|length branches))) - pms (&/|map &/|first pms+bodies) - bodies (&/|map &/|second pms+bodies)] - (|case (&/|reverse pms) - (&/$Nil) - (assert false) - - (&/$Cons _head-pm _tail-pms) - (&/T [(&/fold fuse-pms _head-pm _tail-pms) - bodies]) - ))) - -;; [[Function-Folding Optimization]] - -;; The semantics of Lux establish that all functions are of a single -;; argument and the multi-argument functions are actually nested -;; functions being generated and then applied. -;; This, of course, would generate a lot of waste. -;; To avoid it, Lux actually folds function definitions together, -;; thereby creating functions that can be used both -;; one-argument-at-a-time, and also being called with all, or just a -;; partial amount of their arguments. -;; This avoids generating too many artifacts during compilation, since -;; they get "compressed", and it can also lead to faster execution, by -;; enabling optimized function calls later. - -;; Functions and captured variables have "scopes", which tell which -;; function they are, or to which function they belong. -;; During the folding, inner functions dissapear, since their bodies -;; are merged into their outer "parent" functions. -;; Their scopes must change accordingy. -(defn ^:private de-scope - "(-> Scope Scope Scope Scope)" - [old-scope new-scope scope] - (if (identical? new-scope scope) - old-scope - scope)) - -;; Also, it must be noted that when folding functions, the indexes of -;; the registers have to be changed accodingly. -;; That is what the following "shifting" functions are for. - -;; Shifts the registers for PM operations. -(defn ^:private shift-pattern [pattern] - (|case pattern - ($BindPM _var-id) - ($BindPM (inc _var-id)) - - ($SeqPM _left-pm _right-pm) - ($SeqPM (shift-pattern _left-pm) (shift-pattern _right-pm)) - - ($AltPM _left-pm _right-pm) - ($AltPM (shift-pattern _left-pm) (shift-pattern _right-pm)) - - _ - pattern - )) - -;; Shifts the body of a function after a folding is performed. -(defn shift-function-body - "(-> Scope Scope Bool Optimized Optimized)" - [old-scope new-scope own-body? body] - (|let [[meta body-] body] - (|case body- - ($variant idx is-last? value) - (&/T [meta ($variant idx is-last? (shift-function-body old-scope new-scope own-body? value))]) - - ($tuple elems) - (&/T [meta ($tuple (&/|map (partial shift-function-body old-scope new-scope own-body?) elems))]) - - ($case value [_pm _bodies]) - (&/T [meta ($case (shift-function-body old-scope new-scope own-body? value) - (&/T [(if own-body? - (shift-pattern _pm) - _pm) - (&/|map (partial shift-function-body old-scope new-scope own-body?) _bodies)]))]) - - ($function _register-offset arity scope captured body*) - (|let [scope* (de-scope old-scope new-scope scope)] - (&/T [meta ($function _register-offset - arity - scope* - (&/|map (fn [capture] - (|let [[_name [_meta ($captured _scope _idx _source)]] capture] - (&/T [_name (&/T [_meta ($captured scope* _idx (shift-function-body old-scope new-scope own-body? _source))])]))) - captured) - (shift-function-body old-scope new-scope false body*))])) - - ($ann value-expr type-expr) - (&/T [meta ($ann (shift-function-body old-scope new-scope own-body? value-expr) - type-expr)]) - - ($var var-kind) - (if own-body? - (|case var-kind - (&/$Local 0) - (&/T [meta ($apply body - (&/|list [meta ($var (&/$Local 1))]))]) - - (&/$Local idx) - (&/T [meta ($var (&/$Local (inc idx)))]) - - (&/$Global ?module ?name) - body) - body) - - ;; This special "apply" rule is for handling recursive calls better. - ($apply [meta-0 ($var (&/$Local 0))] args) - (if own-body? - (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))]) - (&/$Cons (&/T [meta-0 ($var (&/$Local 1))]) - (&/|map (partial shift-function-body old-scope new-scope own-body?) args)))]) - (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))]) - (&/|map (partial shift-function-body old-scope new-scope own-body?) args))])) - - ($apply func args) - (&/T [meta ($apply (shift-function-body old-scope new-scope own-body? func) - (&/|map (partial shift-function-body old-scope new-scope own-body?) args))]) - - ($captured scope idx source) - (if own-body? - source - (|case scope - (&/$Cons _ (&/$Cons _ (&/$Nil))) - source - - _ - (&/T [meta ($captured (de-scope old-scope new-scope scope) idx (shift-function-body old-scope new-scope own-body? source))]))) - - ($proc proc-ident args special-args) - (&/T [meta ($proc proc-ident (&/|map (partial shift-function-body old-scope new-scope own-body?) args) special-args)]) - - ($loop _register-offset _inits _body) - (&/T [meta ($loop (if own-body? - (inc _register-offset) - _register-offset) - (&/|map (partial shift-function-body old-scope new-scope own-body?) - _inits) - (shift-function-body old-scope new-scope own-body? _body))]) - - ($iter _iter-register-offset args) - (&/T [meta ($iter (if own-body? - (inc _iter-register-offset) - _iter-register-offset) - (&/|map (partial shift-function-body old-scope new-scope own-body?) args))]) - - ($let _value _register _body) - (&/T [meta ($let (shift-function-body old-scope new-scope own-body? _value) - (if own-body? - (inc _register) - _register) - (shift-function-body old-scope new-scope own-body? _body))]) - - ($record-get _value _path) - (&/T [meta ($record-get (shift-function-body old-scope new-scope own-body? _value) - _path)]) - - ($if _test _then _else) - (&/T [meta ($if (shift-function-body old-scope new-scope own-body? _test) - (shift-function-body old-scope new-scope own-body? _then) - (shift-function-body old-scope new-scope own-body? _else))]) - - _ - body - ))) - -;; [[Record-Manipulation Optimizations]] - -;; If a pattern-matching tree with a single branch is found, and that -;; branch corresponds to a tuple PM, and the body corresponds to a -;; local variable, it's likely that the local refers to some member of -;; the tuple that is being extracted. -;; That is the pattern that is to be expected of record read-access, -;; so this function tries to extract the (possibly nested) path -;; necessary, ending in the data-node of the wanted member. -(defn ^:private record-read-path - "(-> (List PM) Idx (List Idx))" - [pms member-idx] - (loop [current-idx 0 - pms pms] - (|case pms - (&/$Nil) - &/$None - - (&/$Cons _pm _pms) - (|case _pm - (&a-case/$NoTestAC) - (recur (inc current-idx) - _pms) - - (&a-case/$StoreTestAC _register) - (if (= member-idx _register) - (&/|list (&/T [current-idx (&/|empty? _pms)])) - (recur (inc current-idx) - _pms)) - - (&a-case/$TupleTestAC _sub-tests) - (let [sub-path (record-read-path _sub-tests member-idx)] - (if (not (&/|empty? sub-path)) - (&/$Cons (&/T [current-idx (&/|empty? _pms)]) sub-path) - (recur (inc current-idx) - _pms) - )) - - _ - (&/|list)) - ))) - -;; [[Loop Optimizations]] - -;; Lux doesn't offer any looping constructs, relying instead on -;; recursion. -;; Some common usages of recursion can be written more efficiently -;; just using regular loops/iteration. -;; This optimization looks for tail-calls in the function body, -;; rewriting them as jumps to the beginning of the function, while -;; they also updated the necessary local variables for the next iteration. -(defn ^:private optimize-iter - "(-> Int Optimized Optimized)" - [arity optim] - (|let [[meta optim-] optim] - (|case optim- - ($apply [meta-0 ($var (&/$Local 0))] _args) - (if (= arity (&/|length _args)) - (&/T [meta ($iter 1 _args)]) - optim) - - ($case _value [_pattern _bodies]) - (&/T [meta ($case _value - (&/T [_pattern - (&/|map (partial optimize-iter arity) - _bodies)]))]) - - ($let _value _register _body) - (&/T [meta ($let _value _register (optimize-iter arity _body))]) - - ($if _test _then _else) - (&/T [meta ($if _test - (optimize-iter arity _then) - (optimize-iter arity _else))]) - - ($ann _value-expr _type-expr) - (&/T [meta ($ann (optimize-iter arity _value-expr) _type-expr)]) - - _ - optim - ))) - -(defn ^:private contains-self-reference? - "(-> Optimized Bool)" - [body] - (|let [[meta body-] body - stepwise-test (fn [base arg] (or base (contains-self-reference? arg)))] - (|case body- - ($variant idx is-last? value) - (contains-self-reference? value) - - ($tuple elems) - (&/fold stepwise-test false elems) - - ($case value [_pm _bodies]) - (or (contains-self-reference? value) - (&/fold stepwise-test false _bodies)) - - ($function _ _ _ captured _) - (->> captured - (&/|map (fn [capture] - (|let [[_name [_meta ($captured _scope _idx _source)]] capture] - _source))) - (&/fold stepwise-test false)) - - ($ann value-expr type-expr) - (contains-self-reference? value-expr) - - ($var (&/$Local 0)) - true - - ($apply func args) - (or (contains-self-reference? func) - (&/fold stepwise-test false args)) - - ($proc proc-ident args special-args) - (&/fold stepwise-test false args) - - ($loop _register-offset _inits _body) - (or (&/fold stepwise-test false _inits) - (contains-self-reference? _body)) - - ($iter _ args) - (&/fold stepwise-test false args) - - ($let _value _register _body) - (or (contains-self-reference? _value) - (contains-self-reference? _body)) - - ($record-get _value _path) - (contains-self-reference? _value) - - ($if _test _then _else) - (or (contains-self-reference? _test) - (contains-self-reference? _then) - (contains-self-reference? _else)) - - _ - false - ))) - -(defn ^:private pm-loop-transform [register-offset direct? pattern] - (|case pattern - ($BindPM _var-id) - ($BindPM (+ register-offset (if direct? - (- _var-id 2) - (- _var-id 1)))) - - ($SeqPM _left-pm _right-pm) - ($SeqPM (pm-loop-transform register-offset direct? _left-pm) - (pm-loop-transform register-offset direct? _right-pm)) - - ($AltPM _left-pm _right-pm) - ($AltPM (pm-loop-transform register-offset direct? _left-pm) - (pm-loop-transform register-offset direct? _right-pm)) - - _ - pattern - )) - -;; This function must be run STRICTLY before shift-function body, as -;; the transformation assumes that SFB will be invoke after it. -(defn ^:private loop-transform [register-offset direct? body] - (|let [adjust-direct (fn [register] - ;; The register must be decreased once, since - ;; it will be re-increased in - ;; shift-function-body. - ;; The decrease is meant to keep things stable. - (if direct? - ;; And, if this adjustment is done - ;; directly during a loop-transform (and - ;; not indirectly if transforming an inner - ;; loop), then it must be decreased again - ;; because the 0/self var will no longer - ;; exist in the loop's context. - (- register 2) - (- register 1))) - [meta body-] body] - (|case body- - ($variant idx is-last? value) - (&/T [meta ($variant idx is-last? (loop-transform register-offset direct? value))]) - - ($tuple elems) - (&/T [meta ($tuple (&/|map (partial loop-transform register-offset direct?) elems))]) - - ($case value [_pm _bodies]) - (&/T [meta ($case (loop-transform register-offset direct? value) - (&/T [(pm-loop-transform register-offset direct? _pm) - (&/|map (partial loop-transform register-offset direct?) - _bodies)]))]) - - ;; Functions are ignored because they'll be handled properly at shift-function-body - - ($ann value-expr type-expr) - (&/T [meta ($ann (loop-transform register-offset direct? value-expr) - type-expr)]) - - ($var (&/$Local idx)) - ;; The index must be decreased once, because the var index is - ;; 1-based (since 0 is reserved for self-reference). - ;; Then it must be decreased again, since it will be increased - ;; in the shift-function-body call. - ;; Then, I add the offset to ensure the var points to the right register. - (&/T [meta ($var (&/$Local (-> (adjust-direct idx) - (+ register-offset))))]) - - ($apply func args) - (&/T [meta ($apply (loop-transform register-offset direct? func) - (&/|map (partial loop-transform register-offset direct?) args))]) - - ;; Captured-vars are ignored because they'll be handled properly at shift-function-body - - ($proc proc-ident args special-args) - (&/T [meta ($proc proc-ident (&/|map (partial loop-transform register-offset direct?) args) special-args)]) - - ($loop _register-offset _inits _body) - (&/T [meta ($loop (+ register-offset (adjust-direct _register-offset)) - (&/|map (partial loop-transform register-offset direct?) _inits) - (loop-transform register-offset direct? _body))]) - - ($iter _iter-register-offset args) - (&/T [meta ($iter (+ register-offset (adjust-direct _iter-register-offset)) - (&/|map (partial loop-transform register-offset direct?) args))]) - - ($let _value _register _body) - (&/T [meta ($let (loop-transform register-offset direct? _value) - (+ register-offset (adjust-direct _register)) - (loop-transform register-offset direct? _body))]) - - ($record-get _value _path) - (&/T [meta ($record-get (loop-transform register-offset direct? _value) - _path)]) - - ($if _test _then _else) - (&/T [meta ($if (loop-transform register-offset direct? _test) - (loop-transform register-offset direct? _then) - (loop-transform register-offset direct? _else))]) - - _ - body - ))) - -(defn ^:private inline-loop [meta register-offset scope captured args body] - (->> body - (loop-transform register-offset true) - (shift-function-body scope (&/|tail scope) true) - ($loop register-offset args) - (list meta) - (&/T))) - -;; [[Initial Optimization]] - -;; Before any big optimization can be done, the incoming Analysis nodes -;; must be transformed into Optimized nodes, amenable to further transformations. -;; This function does the job, while also detecting (and optimizing) -;; some simple surface patterns it may encounter. -(let [optimize-closure (fn [optimize closure] - (&/|map (fn [capture] - (|let [[_name _analysis] capture] - (&/T [_name (optimize _analysis)]))) - closure))] - (defn ^:private pass-0 - "(-> Bool Analysis Optimized)" - [top-level-func? analysis] - (|let [[meta analysis-] analysis] - (|case analysis- - (&a/$bool value) - (&/T [meta ($bool value)]) - - (&a/$nat value) - (&/T [meta ($nat value)]) - - (&a/$int value) - (&/T [meta ($int value)]) - - (&a/$frac value) - (&/T [meta ($frac value)]) - - (&a/$real value) - (&/T [meta ($real value)]) - - (&a/$char value) - (&/T [meta ($char value)]) - - (&a/$text value) - (&/T [meta ($text value)]) - - (&a/$variant idx is-last? value) - (&/T [meta ($variant idx is-last? (pass-0 top-level-func? value))]) - - (&a/$tuple elems) - (&/T [meta ($tuple (&/|map (partial pass-0 top-level-func?) elems))]) - - (&a/$apply func args) - (|let [=func (pass-0 top-level-func? func) - =args (&/|map (partial pass-0 top-level-func?) args)] - (|case =func - [_ ($ann [_ ($function _register-offset _arity _scope _captured _body)] - _)] - (if (and (= _arity (&/|length =args)) - (not (contains-self-reference? _body))) - (inline-loop meta _register-offset _scope _captured =args _body) - (&/T [meta ($apply =func =args)])) - - _ - (&/T [meta ($apply =func =args)]))) - - (&a/$case value branches) - (let [normal-case-optim (fn [] - (&/T [meta ($case (pass-0 top-level-func? value) - (optimize-pm (&/|map (fn [branch] - (|let [[_pattern _body] branch] - (&/T [_pattern (pass-0 top-level-func? _body)]))) - branches)))]))] - (|case branches - ;; The pattern for a let-expression is a single branch, - ;; tying the value to a register. - (&/$Cons [(&a-case/$StoreTestAC _register) _body] (&/$Nil)) - (&/T [meta ($let (pass-0 top-level-func? value) _register (pass-0 top-level-func? _body))]) - - (&/$Cons [(&a-case/$BoolTestAC false) _else] - (&/$Cons [(&a-case/$BoolTestAC true) _then] - (&/$Nil))) - (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) - - ;; The pattern for a record-get is a single branch, with a - ;; tuple pattern and a body corresponding to a - ;; local-variable extracted from the tuple. - (&/$Cons [(&a-case/$TupleTestAC _sub-tests) [_ (&a/$var (&/$Local _member-idx))]] (&/$Nil)) - (|let [_path (record-read-path _sub-tests _member-idx)] - (if (&/|empty? _path) - ;; If the path is empty, that means it was a - ;; false-positive and normal PM optimization should be - ;; done instead. - (normal-case-optim) - ;; Otherwise, we've got ourselves a record-get expression. - (&/T [meta ($record-get (pass-0 top-level-func? value) _path)]))) - - ;; If no special patterns are found, just do normal PM optimization. - _ - (normal-case-optim))) - - (&a/$lambda _register-offset scope captured body) - (|let [inner-func? (|case body - [_ (&a/$lambda _ _ _ _)] - true - - _ - false)] - (|case (pass-0 (not inner-func?) body) - ;; If the body of a function is another function, that means - ;; no work was done in-between and both layers can be folded - ;; into one. - [_ ($function _ _arity _scope _captured _body)] - (|let [new-arity (inc _arity) - collapsed-body (shift-function-body scope _scope true _body)] - (&/T [meta ($function _register-offset - new-arity - scope - (optimize-closure (partial pass-0 top-level-func?) captured) - (if top-level-func? - (optimize-iter new-arity collapsed-body) - collapsed-body))])) - - ;; Otherwise, they're nothing to be done and we've got a - ;; 1-arity function. - =body - (&/T [meta ($function _register-offset - 1 scope - (optimize-closure (partial pass-0 top-level-func?) captured) - (if top-level-func? - (optimize-iter 1 =body) - =body))]))) - - (&a/$ann value-expr type-expr) - (&/T [meta ($ann (pass-0 top-level-func? value-expr) type-expr)]) - - (&a/$var var-kind) - (&/T [meta ($var var-kind)]) - - (&a/$captured scope idx source) - (&/T [meta ($captured scope idx (pass-0 top-level-func? source))]) - - (&a/$proc proc-ident args special-args) - (&/T [meta ($proc proc-ident (&/|map (partial pass-0 top-level-func?) args) special-args)]) - - _ - (assert false (prn-str 'pass-0 top-level-func? (&/adt->text analysis))) - )))) - -;; [Exports] -(defn optimize - "(-> Analysis Optimized)" - [analysis] - (->> analysis - (pass-0 true))) diff --git a/src/lux/parser.clj b/src/lux/parser.clj deleted file mode 100644 index ceafcd92e..000000000 --- a/src/lux/parser.clj +++ /dev/null @@ -1,117 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.parser - (:require [clojure.template :refer [do-template]] - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return |case]] - [lexer :as &lexer]))) - -;; [Utils] -(def ^:private base-uneven-record-error - "[Parser Error] Records must have an even number of elements.") - -(defn ^:private repeat% [action] - (fn [state] - (|case (action state) - (&/$Left ^String error) - (cond (.contains error base-uneven-record-error) - (&/$Left error) - - (not (.contains error "[Parser Error]")) - (&/$Left error) - - :else - (&/$Right (&/T [state &/$Nil]))) - - (&/$Right state* head) - ((|do [tail (repeat% action)] - (return (&/$Cons head tail))) - state*)))) - -(do-template [ ] - (defn [parse] - (|do [elems (repeat% parse) - token &lexer/lex] - (|case token - [meta ( _)] - (return ( (&/fold &/|++ &/$Nil elems))) - - _ - (&/fail-with-loc (str "[Parser Error] Unbalanced " ".")) - ))) - - ^:private parse-form &lexer/$Close_Paren "parantheses" &/$FormS - ^:private parse-tuple &lexer/$Close_Bracket "brackets" &/$TupleS - ) - -(defn ^:private parse-record [parse] - (|do [elems* (repeat% parse) - token &lexer/lex - :let [elems (&/fold &/|++ &/$Nil elems*)]] - (|case token - [meta (&lexer/$Close_Brace _)] - (if (even? (&/|length elems)) - (return (&/$RecordS (&/|as-pairs elems))) - (&/fail-with-loc base-uneven-record-error)) - - _ - (&/fail-with-loc "[Parser Error] Unbalanced braces.") - ))) - -;; [Interface] -(def parse - (|do [token &lexer/lex - :let [[meta token*] token]] - (|case token* - (&lexer/$White_Space _) - (return &/$Nil) - - (&lexer/$Comment _) - (return &/$Nil) - - (&lexer/$Bool ?value) - (return (&/|list (&/T [meta (&/$BoolS (Boolean/parseBoolean ?value))]))) - - (&lexer/$Nat ?value) - (return (&/|list (&/T [meta (&/$NatS (Long/parseUnsignedLong ?value))]))) - - (&lexer/$Int ?value) - (return (&/|list (&/T [meta (&/$IntS (Long/parseLong ?value))]))) - - (&lexer/$Frac ?value) - (return (&/|list (&/T [meta (&/$FracS (&/decode-frac ?value))]))) - - (&lexer/$Real ?value) - (return (&/|list (&/T [meta (&/$RealS (Double/parseDouble ?value))]))) - - (&lexer/$Char ^String ?value) - (return (&/|list (&/T [meta (&/$CharS (.charAt ?value 0))]))) - - (&lexer/$Text ?value) - (return (&/|list (&/T [meta (&/$TextS ?value)]))) - - (&lexer/$Symbol ?ident) - (return (&/|list (&/T [meta (&/$SymbolS ?ident)]))) - - (&lexer/$Tag ?ident) - (return (&/|list (&/T [meta (&/$TagS ?ident)]))) - - (&lexer/$Open_Paren _) - (|do [syntax (parse-form parse)] - (return (&/|list (&/T [meta syntax])))) - - (&lexer/$Open_Bracket _) - (|do [syntax (parse-tuple parse)] - (return (&/|list (&/T [meta syntax])))) - - (&lexer/$Open_Brace _) - (|do [syntax (parse-record parse)] - (return (&/|list (&/T [meta syntax])))) - - _ - (&/fail-with-loc "[Parser Error] Unknown lexer token.") - ))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj deleted file mode 100644 index 5a7734061..000000000 --- a/src/lux/reader.clj +++ /dev/null @@ -1,141 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.reader - (:require [clojure.string :as string] - clojure.core.match - clojure.core.match.array - [lux.base :as & :refer [defvariant |do return* return fail* |let |case]])) - -;; [Tags] -(defvariant - ("No" 1) - ("Done" 1) - ("Yes" 2)) - -;; [Utils] -(defn ^:private with-line [body] - (fn [state] - (|case (&/get$ &/$source state) - (&/$Nil) - (fail* "[Reader Error] EOF") - - (&/$Cons [[file-name line-num column-num] line] - more) - (|case (body file-name line-num column-num line) - ($No msg) - ((&/fail-with-loc msg) state) - - ($Done output) - (return* (&/set$ &/$source more state) - output) - - ($Yes output line*) - (return* (&/set$ &/$source (&/$Cons line* more) state) - output)) - ))) - -(defn ^:private with-lines [body] - (fn [state] - (|case (body (&/get$ &/$source state)) - (&/$Right reader* match) - (return* (&/set$ &/$source reader* state) - match) - - (&/$Left msg) - ((&/fail-with-loc msg) state) - ))) - -(defn ^:private re-find! [^java.util.regex.Pattern regex column ^String line] - (let [matcher (doto (.matcher regex line) - (.region column (.length line)) - (.useAnchoringBounds true))] - (when (.find matcher) - (.group matcher 0)))) - -;; [Exports] -(defn read-regex [regex] - (with-line - (fn [file-name line-num column-num ^String line] - (if-let [^String match (re-find! regex column-num line)] - (let [match-length (.length match) - column-num* (+ column-num match-length)] - (if (= column-num* (.length line)) - ($Done (&/T [(&/T [file-name line-num column-num]) true match])) - ($Yes (&/T [(&/T [file-name line-num column-num]) false match]) - (&/T [(&/T [file-name line-num column-num*]) line])))) - ($No (str "[Reader Error] Pattern failed: " regex)))))) - -(defn read-regex+ [regex] - (with-lines - (fn [reader] - (loop [prefix "" - reader* reader] - (|case reader* - (&/$Nil) - (&/$Left "[Reader Error] EOF") - - (&/$Cons [[file-name line-num column-num] ^String line] - reader**) - (if-let [^String match (re-find! regex column-num line)] - (let [match-length (.length match) - column-num* (+ column-num match-length) - prefix* (if (= 0 column-num) - (str prefix "\n" match) - (str prefix match))] - (if (= column-num* (.length line)) - (recur prefix* reader**) - (&/$Right (&/T [(&/$Cons (&/T [(&/T [file-name line-num column-num*]) line]) - reader**) - (&/T [(&/T [file-name line-num column-num]) prefix*])])))) - (&/$Left (str "[Reader Error] Pattern failed: " regex)))))))) - -(defn read-text [^String text] - "(-> Text (Reader Text))" - (with-line - (fn [file-name line-num column-num ^String line] - (if (.startsWith line text column-num) - (let [match-length (.length text) - column-num* (+ column-num match-length)] - (if (= column-num* (.length line)) - ($Done (&/T [(&/T [file-name line-num column-num]) true text])) - ($Yes (&/T [(&/T [file-name line-num column-num]) false text]) - (&/T [(&/T [file-name line-num column-num*]) line])))) - ($No (str "[Reader Error] Text failed: " text)))))) - -(defn read-text? [^String text] - "(-> Text (Reader (Maybe Text)))" - (with-line - (fn [file-name line-num column-num ^String line] - (if (.startsWith line text column-num) - (let [match-length (.length text) - column-num* (+ column-num match-length)] - (if (= column-num* (.length line)) - ($Done (&/T [(&/T [file-name line-num column-num]) true (&/$Some text)])) - ($Yes (&/T [(&/T [file-name line-num column-num]) false (&/$Some text)]) - (&/T [(&/T [file-name line-num column-num*]) line])))) - ($Yes (&/T [(&/T [file-name line-num column-num]) false &/$None]) - (&/T [(&/T [file-name line-num column-num]) line])))))) - -(defn from [^String name ^String source-code] - (let [lines (string/split-lines source-code) - indexed-lines (map (fn [line line-num] - (&/T [(&/T [name (inc line-num) 0]) - line])) - lines - (range (count lines)))] - (reduce (fn [tail head] (&/$Cons head tail)) - &/$Nil - (reverse indexed-lines)))) - -(defn with-source [name content body] - (fn [state] - (|let [old-source (&/get$ &/$source state)] - (|case (body (&/set$ &/$source (from name content) state)) - (&/$Left error) - (&/$Left error) - - (&/$Right state* output) - (&/$Right (&/T [(&/set$ &/$source old-source state*) output])))))) diff --git a/src/lux/repl.clj b/src/lux/repl.clj deleted file mode 100644 index 195f3dc3e..000000000 --- a/src/lux/repl.clj +++ /dev/null @@ -1,89 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.repl - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail* |case]] - [type :as &type] - [analyser :as &analyser] - [optimizer :as &optimizer] - [compiler :as &compiler]) - [lux.compiler.cache :as &cache] - [lux.analyser.base :as &a-base] - [lux.analyser.lux :as &a-lux] - [lux.analyser.module :as &module]) - (:import (java.io InputStreamReader - BufferedReader))) - -;; [Utils] -(def ^:private repl-module "REPL") - -(defn ^:private repl-cursor [repl-line] - (&/T [repl-module repl-line 0])) - -(defn ^:private init [source-dirs] - (do (&compiler/init!) - (|case ((|do [_ (&compiler/compile-module source-dirs "lux") - _ (&cache/delete repl-module) - _ (&module/create-module repl-module 0) - _ (fn [?state] - (return* (&/set$ &/$source - (&/|list (&/T [(repl-cursor -1) "(;import lux)"])) - ?state) - nil)) - analysed-tokens (&analyser/repl-analyse &optimizer/optimize &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers) - eval-values (->> analysed-tokens (&/|map &optimizer/optimize) (&/map% &compiler/eval!))] - (return nil)) - (&/init-state &/$REPL)) - (&/$Right ?state _) - (do (println) - (println "Welcome to the REPL!") - (println "Type \"exit\" to leave.") - (println) - ?state) - - (&/$Left ?message) - (assert false ?message)) - )) - -;; [Values] -(defn repl [source-dirs] - (with-open [input (->> System/in (new InputStreamReader) (new BufferedReader))] - (loop [state (init source-dirs) - repl-line 0 - multi-line? false] - (let [_ (if (not multi-line?) - (.print System/out "> ") - (.print System/out " ")) - line (.readLine input)] - (if (= "exit" line) - (println "Till next time...") - (let [line* (&/|list (&/T [(repl-cursor repl-line) line])) - state* (&/update$ &/$source - (fn [_source] (&/|++ _source line*)) - state)] - (|case ((|do [analysed-tokens (&analyser/repl-analyse &optimizer/optimize &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers) - eval-values (->> analysed-tokens (&/|map &optimizer/optimize) (&/map% &compiler/eval!)) - :let [outputs (map (fn [analysis value] - (|let [[[_type _cursor] _term] analysis] - [_type value])) - (&/->seq analysed-tokens) - (&/->seq eval-values))]] - (return outputs)) - state*) - (&/$Right state** outputs) - (do (doseq [[_type _value] outputs] - (.println System/out (str "=> " (pr-str _value) "\n:: " (&type/show-type _type)"\n"))) - (recur state** (inc repl-line) false)) - - (&/$Left ^String ?message) - (if (or (= "[Reader Error] EOF" ?message) - (.contains ?message "[Parser Error] Unbalanced ")) - (recur state* (inc repl-line) true) - (do (println ?message) - (recur state (inc repl-line) false))) - )))) - ))) diff --git a/src/lux/type.clj b/src/lux/type.clj deleted file mode 100644 index d387053dc..000000000 --- a/src/lux/type.clj +++ /dev/null @@ -1,972 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.type - (:refer-clojure :exclude [deref apply merge bound?]) - (:require [clojure.template :refer [do-template]] - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]]) - [lux.type.host :as &&host])) - -(declare show-type - type=) - -;; [Utils] -(defn |list? [xs] - (|case xs - (&/$Nil) - true - - (&/$Cons x xs*) - (|list? xs*) - - _ - false)) - -(def empty-env &/$Nil) - -(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil))) -(def Nat (&/$NamedT (&/T ["lux" "Nat"]) (&/$HostT &&host/nat-data-tag &/$Nil))) -(def Frac (&/$NamedT (&/T ["lux" "Frac"]) (&/$HostT &&host/frac-data-tag &/$Nil))) -(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "java.lang.Long" &/$Nil))) -(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "java.lang.Double" &/$Nil))) -(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "java.lang.Character" &/$Nil))) -(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "java.lang.String" &/$Nil))) -(def Ident (&/$NamedT (&/T ["lux" "Ident"]) (&/$ProdT Text Text))) - -(def Bottom - (&/$NamedT (&/T ["lux" "Bottom"]) - (&/$UnivQ empty-env - (&/$BoundT 1)))) - -(def IO - (&/$NamedT (&/T ["lux/codata" "IO"]) - (&/$UnivQ empty-env - (&/$LambdaT &/$VoidT (&/$BoundT 1))))) - -(def List - (&/$NamedT (&/T ["lux" "List"]) - (&/$UnivQ empty-env - (&/$SumT - ;; lux;Nil - &/$UnitT - ;; lux;Cons - (&/$ProdT (&/$BoundT 1) - (&/$AppT (&/$BoundT 0) - (&/$BoundT 1))))))) - -(def Maybe - (&/$NamedT (&/T ["lux" "Maybe"]) - (&/$UnivQ empty-env - (&/$SumT - ;; lux;None - &/$UnitT - ;; lux;Some - (&/$BoundT 1)) - ))) - -(def Type - (&/$NamedT (&/T ["lux" "Type"]) - (let [Type (&/$AppT (&/$BoundT 0) (&/$BoundT 1)) - TypeList (&/$AppT List Type) - TypePair (&/$ProdT Type Type)] - (&/$AppT (&/$UnivQ empty-env - (&/$SumT - ;; HostT - (&/$ProdT Text TypeList) - (&/$SumT - ;; VoidT - &/$UnitT - (&/$SumT - ;; UnitT - &/$UnitT - (&/$SumT - ;; SumT - TypePair - (&/$SumT - ;; ProdT - TypePair - (&/$SumT - ;; LambdaT - TypePair - (&/$SumT - ;; BoundT - Nat - (&/$SumT - ;; VarT - Nat - (&/$SumT - ;; ExT - Nat - (&/$SumT - ;; UnivQ - (&/$ProdT TypeList Type) - (&/$SumT - ;; ExQ - (&/$ProdT TypeList Type) - (&/$SumT - ;; AppT - TypePair - ;; NamedT - (&/$ProdT Ident Type))))))))))))) - ) - &/$VoidT)))) - -(def Ann-Value - (&/$NamedT (&/T ["lux" "Ann-Value"]) - (let [Ann-Value (&/$AppT (&/$BoundT 0) (&/$BoundT 1))] - (&/$AppT (&/$UnivQ empty-env - (&/$SumT - ;; BoolM - Bool - (&/$SumT - ;; NatM - Nat - (&/$SumT - ;; IntM - Int - (&/$SumT - ;; FracM - Frac - (&/$SumT - ;; RealM - Real - (&/$SumT - ;; CharM - Char - (&/$SumT - ;; TextM - Text - (&/$SumT - ;; IdentM - Ident - (&/$SumT - ;; ListM - (&/$AppT List Ann-Value) - ;; DictM - (&/$AppT List (&/$ProdT Text Ann-Value))))))))))) - ) - &/$VoidT)))) - -(def Anns - (&/$NamedT (&/T ["lux" "Anns"]) - (&/$AppT List (&/$ProdT Ident Ann-Value)))) - -(def Macro) - -(defn set-macro-type! [type] - (def Macro type) - nil) - -(defn bound? [id] - (fn [state] - (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] - (|case type - (&/$Some type*) - (return* state true) - - (&/$None) - (return* state false)) - (fail* (str "[Type Error] Unknown type-var: " id))))) - -(defn deref [id] - (fn [state] - (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] - (|case type* - (&/$Some type) - (return* state type) - - (&/$None) - (fail* (str "[Type Error] Unbound type-var: " id))) - (fail* (str "[Type Error] Unknown type-var: " id))))) - -(defn deref+ [type] - (|case type - (&/$VarT id) - (deref id) - - _ - (fail (str "[Type Error] Type is not a variable: " (show-type type))) - )) - -(defn set-var [id type] - (fn [state] - (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] - (|case tvar - (&/$Some bound) - (if (type= type bound) - (return* state nil) - (fail* (str "[Type Error] Can't re-bind type var: " id " | Current type: " (show-type bound)))) - - (&/$None) - (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) - ts)) - state) - nil)) - (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) - -(defn reset-var [id type] - (fn [state] - (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] - (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) - ts)) - state) - nil) - (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) - -(defn unset-var [id] - (fn [state] - (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] - (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id &/$None %) - ts)) - state) - nil) - (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) - -;; [Exports] -;; Type vars -(def create-var - (fn [state] - (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] - (return* (&/update$ &/$type-vars #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [ms] (&/|put id &/$None ms)))) - state) - id)))) - -(def existential - ;; (Lux Type) - (|do [seed &/gen-id] - (return (&/$ExT seed)))) - -(declare clean*) -(defn delete-var [id] - (|do [? (bound? id) - _ (if ? - (return nil) - (|do [ex existential] - (set-var id ex)))] - (fn [state] - ((|do [mappings* (&/map% (fn [binding] - (|let [[?id ?type] binding] - (if (.equals ^Object id ?id) - (return binding) - (|case ?type - (&/$None) - (return binding) - - (&/$Some ?type*) - (|case ?type* - (&/$VarT ?id*) - (if (.equals ^Object id ?id*) - (return (&/T [?id &/$None])) - (return binding)) - - _ - (|do [?type** (clean* id ?type*)] - (return (&/T [?id (&/$Some ?type**)])))) - )))) - (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] - (fn [state] - (return* (&/update$ &/$type-vars #(&/set$ &/$mappings (&/|remove id mappings*) %) - state) - nil))) - state)))) - -(defn with-var [k] - (|do [id create-var - output (k (&/$VarT id)) - _ (delete-var id)] - (return output))) - -(defn clean* [?tid type] - (|case type - (&/$VarT ?id) - (if (.equals ^Object ?tid ?id) - (|do [? (bound? ?id)] - (if ? - (deref ?id) - (return type))) - (|do [? (bound? ?id)] - (if ? - (|do [=type (deref ?id) - ==type (clean* ?tid =type)] - (|case ==type - (&/$VarT =id) - (if (.equals ^Object ?tid =id) - (|do [_ (unset-var ?id)] - (return type)) - (|do [_ (reset-var ?id ==type)] - (return type))) - - _ - (|do [_ (reset-var ?id ==type)] - (return type)))) - (return type))) - ) - - (&/$HostT ?name ?params) - (|do [=params (&/map% (partial clean* ?tid) ?params)] - (return (&/$HostT ?name =params))) - - (&/$LambdaT ?arg ?return) - (|do [=arg (clean* ?tid ?arg) - =return (clean* ?tid ?return)] - (return (&/$LambdaT =arg =return))) - - (&/$AppT ?lambda ?param) - (|do [=lambda (clean* ?tid ?lambda) - =param (clean* ?tid ?param)] - (return (&/$AppT =lambda =param))) - - (&/$ProdT ?left ?right) - (|do [=left (clean* ?tid ?left) - =right (clean* ?tid ?right)] - (return (&/$ProdT =left =right))) - - (&/$SumT ?left ?right) - (|do [=left (clean* ?tid ?left) - =right (clean* ?tid ?right)] - (return (&/$SumT =left =right))) - - (&/$UnivQ ?env ?body) - (|do [=env (&/map% (partial clean* ?tid) ?env) - body* (clean* ?tid ?body)] ;; TODO: DON'T CLEAN THE BODY - (return (&/$UnivQ =env body*))) - - (&/$ExQ ?env ?body) - (|do [=env (&/map% (partial clean* ?tid) ?env) - body* (clean* ?tid ?body)] ;; TODO: DON'T CLEAN THE BODY - (return (&/$ExQ =env body*))) - - _ - (return type) - )) - -(defn clean [tvar type] - (|case tvar - (&/$VarT ?id) - (clean* ?id type) - - _ - (fail (str "[Type Error] Not type-var: " (show-type tvar))))) - -(defn ^:private unravel-fun [type] - (|case type - (&/$LambdaT ?in ?out) - (|let [[??out ?args] (unravel-fun ?out)] - (&/T [??out (&/$Cons ?in ?args)])) - - _ - (&/T [type &/$Nil]))) - -(defn ^:private unravel-app [fun-type] - (|case fun-type - (&/$AppT ?left ?right) - (|let [[?fun-type ?args] (unravel-app ?left)] - (&/T [?fun-type (&/|++ ?args (&/|list ?right))])) - - _ - (&/T [fun-type &/$Nil]))) - -(do-template [ ] - (do (defn [type] - "(-> Type (List Type))" - (|case type - ( left right) - (&/$Cons left ( right)) - - _ - (&/|list type))) - - (defn [tag type] - "(-> Int Type (Lux Type))" - (|case type - (&/$NamedT ?name ?type) - ( tag ?type) - - ( ?left ?right) - (|case (&/T [tag ?right]) - [0 _] (return ?left) - [1 ( ?left* _)] (return ?left*) - [1 _] (return ?right) - [_ ( _ _)] ( (dec tag) ?right) - _ (fail (str "[Type Error] " " lacks member: " tag " | " (show-type type)))) - - _ - (fail (str "[Type Error] Type is not a " ": " (show-type type)))))) - - &/$SumT flatten-sum sum-at "Sum" - &/$ProdT flatten-prod prod-at "Product" - ) - -(do-template [ ] - (defn [types] - "(-> (List Type) Type)" - (|case (&/|reverse types) - (&/$Cons last prevs) - (&/fold (fn [right left] ( left right)) last prevs) - - (&/$Nil) - )) - - Variant$ &/$SumT &/$VoidT - Tuple$ &/$ProdT &/$UnitT - ) - -(defn show-type [^objects type] - (|case type - (&/$HostT name params) - (|case params - (&/$Nil) - (str "(host " name ")") - - _ - (str "(host " name " " (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - - (&/$VoidT) - "Void" - - (&/$UnitT) - "Unit" - - (&/$ProdT _) - (str "[" (->> (flatten-prod type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) "]") - - (&/$SumT _) - (str "(| " (->> (flatten-sum type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") - - (&/$LambdaT input output) - (|let [[?out ?ins] (unravel-fun type)] - (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) - - (&/$VarT id) - (str "⌈v:" id "⌋") - - (&/$ExT ?id) - (str "⟨e:" ?id "⟩") - - (&/$BoundT idx) - (str idx) - - (&/$AppT _ _) - (|let [[?call-fun ?call-args] (unravel-app type)] - (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - - (&/$UnivQ ?env ?body) - (str "(All " (show-type ?body) ")") - - (&/$ExQ ?env ?body) - (str "(Ex " (show-type ?body) ")") - - (&/$NamedT ?name ?type) - (&/ident->text ?name) - - _ - (assert false (prn-str 'show-type (&/adt->text type))))) - -(defn type= [x y] - (or (clojure.lang.Util/identical x y) - (let [output (|case [x y] - [(&/$NamedT [?xmodule ?xname] ?xtype) (&/$NamedT [?ymodule ?yname] ?ytype)] - (and (= ?xmodule ?ymodule) - (= ?xname ?yname)) - - [(&/$HostT xname xparams) (&/$HostT yname yparams)] - (and (.equals ^Object xname yname) - (= (&/|length xparams) (&/|length yparams)) - (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams)) - - [(&/$VoidT) (&/$VoidT)] - true - - [(&/$UnitT) (&/$UnitT)] - true - - [(&/$ProdT xL xR) (&/$ProdT yL yR)] - (and (type= xL yL) - (type= xR yR)) - - [(&/$SumT xL xR) (&/$SumT yL yR)] - (and (type= xL yL) - (type= xR yR)) - - [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] - (and (type= xinput yinput) - (type= xoutput youtput)) - - [(&/$VarT xid) (&/$VarT yid)] - (.equals ^Object xid yid) - - [(&/$BoundT xidx) (&/$BoundT yidx)] - (= xidx yidx) - - [(&/$ExT xid) (&/$ExT yid)] - (.equals ^Object xid yid) - - [(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)] - (and (type= xlambda ylambda) (type= xparam yparam)) - - [(&/$UnivQ xenv xbody) (&/$UnivQ yenv ybody)] - (type= xbody ybody) - - [(&/$NamedT ?xname ?xtype) _] - (type= ?xtype y) - - [_ (&/$NamedT ?yname ?ytype)] - (type= x ?ytype) - - [_ _] - false - )] - output))) - -(defn ^:private fp-get [k fixpoints] - (|let [[e a] k] - (|case fixpoints - (&/$Nil) - &/$None - - (&/$Cons [[e* a*] v*] fixpoints*) - (if (and (type= e e*) - (type= a a*)) - (&/$Some v*) - (fp-get k fixpoints*)) - ))) - -(defn ^:private fp-put [k v fixpoints] - (&/$Cons (&/T [k v]) fixpoints)) - -(defn show-type+ [type] - (|case type - (&/$VarT ?id) - (fn [state] - (|case ((deref ?id) state) - (&/$Right state* bound) - (return* state (str (show-type type) " = " (show-type bound))) - - (&/$Left _) - (return* state (show-type type)))) - - _ - (return (show-type type)))) - -(defn ^:private check-error [err expected actual] - (|do [=expected (show-type+ expected) - =actual (show-type+ actual)] - (&/fail-with-loc (str (if (= "" err) err (str err "\n")) - "[Type Checker]\n" - "Expected: " =expected "\n\n" - "Actual: " =actual - "\n")))) - -(defn beta-reduce [env type] - (|case type - (&/$HostT ?name ?params) - (&/$HostT ?name (&/|map (partial beta-reduce env) ?params)) - - (&/$SumT ?left ?right) - (&/$SumT (beta-reduce env ?left) (beta-reduce env ?right)) - - (&/$ProdT ?left ?right) - (&/$ProdT (beta-reduce env ?left) (beta-reduce env ?right)) - - (&/$AppT ?type-fn ?type-arg) - (&/$AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) - - (&/$UnivQ ?local-env ?local-def) - (|case ?local-env - (&/$Nil) - (&/$UnivQ env ?local-def) - - _ - type) - - (&/$ExQ ?local-env ?local-def) - (|case ?local-env - (&/$Nil) - (&/$ExQ env ?local-def) - - _ - type) - - (&/$LambdaT ?input ?output) - (&/$LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) - - (&/$BoundT ?idx) - (|case (&/|at ?idx env) - (&/$Some bound) - (beta-reduce env bound) - - _ - (assert false (str "[Type Error] Unknown var: " ?idx " | " (&/->seq (&/|map show-type env))))) - - _ - type - )) - -(defn apply-type [type-fn param] - (|case type-fn - (&/$UnivQ local-env local-def) - (return (beta-reduce (->> local-env - (&/$Cons param) - (&/$Cons type-fn)) - local-def)) - - (&/$ExQ local-env local-def) - (return (beta-reduce (->> local-env - (&/$Cons param) - (&/$Cons type-fn)) - local-def)) - - (&/$AppT F A) - (|do [type-fn* (apply-type F A)] - (apply-type type-fn* param)) - - (&/$NamedT ?name ?type) - (apply-type ?type param) - - ;; TODO: This one must go... - (&/$ExT id) - (return (&/$AppT type-fn param)) - - (&/$VarT id) - (|do [=type-fun (deref id)] - (apply-type =type-fun param)) - - _ - (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) - -(def ^:private init-fixpoints &/$Nil) - -(defn ^:private check* [class-loader fixpoints invariant?? expected actual] - (if (clojure.lang.Util/identical expected actual) - (return fixpoints) - (&/with-attempt - (|case [expected actual] - [(&/$VarT ?eid) (&/$VarT ?aid)] - (if (.equals ^Object ?eid ?aid) - (return fixpoints) - (|do [ebound (fn [state] - (|case ((deref ?eid) state) - (&/$Right state* ebound) - (return* state* (&/$Some ebound)) - - (&/$Left _) - (return* state &/$None))) - abound (fn [state] - (|case ((deref ?aid) state) - (&/$Right state* abound) - (return* state* (&/$Some abound)) - - (&/$Left _) - (return* state &/$None)))] - (|case [ebound abound] - [(&/$None _) (&/$None _)] - (|do [_ (set-var ?eid actual)] - (return fixpoints)) - - [(&/$Some etype) (&/$None _)] - (check* class-loader fixpoints invariant?? etype actual) - - [(&/$None _) (&/$Some atype)] - (check* class-loader fixpoints invariant?? expected atype) - - [(&/$Some etype) (&/$Some atype)] - (check* class-loader fixpoints invariant?? etype atype)))) - - [(&/$VarT ?id) _] - (fn [state] - (|case ((set-var ?id actual) state) - (&/$Right state* _) - (return* state* fixpoints) - - (&/$Left _) - ((|do [bound (deref ?id)] - (check* class-loader fixpoints invariant?? bound actual)) - state))) - - [_ (&/$VarT ?id)] - (fn [state] - (|case ((set-var ?id expected) state) - (&/$Right state* _) - (return* state* fixpoints) - - (&/$Left _) - ((|do [bound (deref ?id)] - (check* class-loader fixpoints invariant?? expected bound)) - state))) - - [(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)] - (if (= eid aid) - (check* class-loader fixpoints invariant?? eA aA) - (check-error "" expected actual)) - - [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] - (fn [state] - (|case ((|do [F1 (deref ?id)] - (check* class-loader fixpoints invariant?? (&/$AppT F1 A1) actual)) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - (|case F2 - (&/$UnivQ (&/$Cons _) _) - ((|do [actual* (apply-type F2 A2)] - (check* class-loader fixpoints invariant?? expected actual*)) - state) - - (&/$ExT _) - ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2)] - (check* class-loader fixpoints* invariant?? A1 A2)) - state) - - _ - ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2) - e* (apply-type F2 A1) - a* (apply-type F2 A2)] - (check* class-loader fixpoints* invariant?? e* a*)) - state)))) - - [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] - (fn [state] - (|case ((|do [F2 (deref ?id)] - (check* class-loader fixpoints invariant?? expected (&/$AppT F2 A2))) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - ((|do [fixpoints* (check* class-loader fixpoints invariant?? F1 (&/$VarT ?id)) - e* (apply-type F1 A1) - a* (apply-type F1 A2)] - (check* class-loader fixpoints* invariant?? e* a*)) - state))) - - [(&/$AppT F A) _] - (let [fp-pair (&/T [expected actual]) - _ (when (> (&/|length fixpoints) 40) - (println 'FIXPOINTS (->> (&/|keys fixpoints) - (&/|map (fn [pair] - (|let [[e a] pair] - (str (show-type e) ":+:" - (show-type a))))) - (&/|interpose "\n\n") - (&/fold str ""))) - (assert false (prn-str 'check* '[(&/$AppT F A) _] (&/|length fixpoints) (show-type expected) (show-type actual))))] - (|case (fp-get fp-pair fixpoints) - (&/$Some ?) - (if ? - (return fixpoints) - (check-error "" expected actual)) - - (&/$None) - (|do [expected* (apply-type F A)] - (check* class-loader (fp-put fp-pair true fixpoints) invariant?? expected* actual)))) - - [_ (&/$AppT (&/$ExT aid) A)] - (check-error "" expected actual) - - [_ (&/$AppT F A)] - (|do [actual* (apply-type F A)] - (check* class-loader fixpoints invariant?? expected actual*)) - - [(&/$UnivQ _) _] - (|do [$arg existential - expected* (apply-type expected $arg)] - (check* class-loader fixpoints invariant?? expected* actual)) - - [_ (&/$UnivQ _)] - (with-var - (fn [$arg] - (|do [actual* (apply-type actual $arg) - =output (check* class-loader fixpoints invariant?? expected actual*) - _ (clean $arg expected)] - (return =output)))) - - [(&/$ExQ e!env e!def) _] - (with-var - (fn [$arg] - (|do [expected* (apply-type expected $arg) - =output (check* class-loader fixpoints invariant?? expected* actual) - _ (clean $arg actual)] - (return =output)))) - - [_ (&/$ExQ a!env a!def)] - (|do [$arg existential - actual* (apply-type actual $arg)] - (check* class-loader fixpoints invariant?? expected actual*)) - - [(&/$HostT e!data) (&/$HostT a!data)] - (&&host/check-host-types (partial check* class-loader fixpoints true) - check-error - fixpoints - existential - class-loader - invariant?? - e!data - a!data) - - [(&/$VoidT) (&/$VoidT)] - (return fixpoints) - - [(&/$UnitT) (&/$UnitT)] - (return fixpoints) - - [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] - (|do [fixpoints* (check* class-loader fixpoints invariant?? aI eI)] - (check* class-loader fixpoints* invariant?? eO aO)) - - [(&/$ProdT eL eR) (&/$ProdT aL aR)] - (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)] - (check* class-loader fixpoints* invariant?? eR aR)) - - [(&/$SumT eL eR) (&/$SumT aL aR)] - (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)] - (check* class-loader fixpoints* invariant?? eR aR)) - - [(&/$ExT e!id) (&/$ExT a!id)] - (if (.equals ^Object e!id a!id) - (return fixpoints) - (check-error "" expected actual)) - - [(&/$NamedT _ ?etype) _] - (check* class-loader fixpoints invariant?? ?etype actual) - - [_ (&/$NamedT _ ?atype)] - (check* class-loader fixpoints invariant?? expected ?atype) - - [_ _] - (fail "")) - (fn [err] - (check-error err expected actual))))) - -(defn check [expected actual] - (|do [class-loader &/loader - _ (check* class-loader init-fixpoints false expected actual)] - (return nil))) - -(defn actual-type [type] - "(-> Type (Lux Type))" - (|case type - (&/$AppT ?all ?param) - (|do [type* (apply-type ?all ?param)] - (actual-type type*)) - - (&/$VarT id) - (|do [=type (deref id)] - (actual-type =type)) - - (&/$NamedT ?name ?type) - (actual-type ?type) - - _ - (return type) - )) - -(defn type-name [type] - "(-> Type (Lux Ident))" - (|case type - (&/$NamedT name _) - (return name) - - _ - (fail (str "[Type Error] Type is not named: " (show-type type))) - )) - -(defn unknown? [type] - "(-> Type (Lux Bool))" - (|case type - (&/$VarT id) - (|do [? (bound? id)] - (return (not ?))) - - _ - (return false))) - -(defn resolve-type [type] - "(-> Type (Lux Type))" - (|case type - (&/$VarT id) - (|do [? (bound? id)] - (if ? - (deref id) - (return type))) - - _ - (return type))) - -(defn tuple-types-for [size-members type] - "(-> Int Type [Int (List Type)])" - (|let [?member-types (flatten-prod type) - size-types (&/|length ?member-types)] - (if (>= size-types size-members) - (&/T [size-members (&/|++ (&/|take (dec size-members) ?member-types) - (&/|list (|case (->> ?member-types (&/|drop (dec size-members)) (&/|reverse)) - (&/$Cons last prevs) - (&/fold (fn [right left] (&/$ProdT left right)) - last prevs))))]) - (&/T [size-types ?member-types]) - ))) - -(do-template [ ] - (defn [types] - (|case (&/|reverse types) - (&/$Nil) - - - (&/$Cons type (&/$Nil)) - type - - (&/$Cons last prevs) - (&/fold (fn [r l] ( l r)) last prevs))) - - fold-prod &/$UnitT &/$ProdT - fold-sum &/$VoidT &/$SumT - ) - -(def create-var+ - (|do [id create-var] - (return (&/$VarT id)))) - -(defn ^:private push-app [inf-type inf-var] - (|case inf-type - (&/$AppT inf-type* inf-var*) - (&/$AppT (push-app inf-type* inf-var) inf-var*) - - _ - (&/$AppT inf-type inf-var))) - -(defn ^:private push-name [name inf-type] - (|case inf-type - (&/$AppT inf-type* inf-var*) - (&/$AppT (push-name name inf-type*) inf-var*) - - _ - (&/$NamedT name inf-type))) - -(defn ^:private push-univq [env inf-type] - (|case inf-type - (&/$AppT inf-type* inf-var*) - (&/$AppT (push-univq env inf-type*) inf-var*) - - _ - (&/$UnivQ env inf-type))) - -(defn instantiate-inference [type] - (|case type - (&/$NamedT ?name ?type) - (|do [output (instantiate-inference ?type)] - (return (push-name ?name output))) - - (&/$UnivQ _aenv _abody) - (|do [inf-var create-var - output (instantiate-inference _abody)] - (return (push-univq _aenv (push-app output (&/$VarT inf-var))))) - - _ - (return type))) diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj deleted file mode 100644 index 462e1aebe..000000000 --- a/src/lux/type/host.clj +++ /dev/null @@ -1,352 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.type.host - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]]) - [lux.host.generics :as &host-generics]) - (:import (java.lang.reflect GenericArrayType - ParameterizedType - TypeVariable - WildcardType))) - -;; [Exports] -(def array-data-tag "#Array") -(def null-data-tag "#Null") -(def nat-data-tag "#Nat") -(def frac-data-tag "#Frac") - -;; [Utils] -(defn ^:private trace-lineage* [^Class super-class ^Class sub-class] - "(-> Class Class (List Class))" - ;; Either they're both interfaces, of they're both classes - (let [valid-sub? #(if (or (= super-class %) - (.isAssignableFrom super-class %)) - % - nil)] - (cond (.isInterface sub-class) - (loop [sub-class sub-class - stack (&/|list)] - (let [super-interface (some valid-sub? (.getInterfaces sub-class))] - (if (= super-class super-interface) - (&/$Cons super-interface stack) - (recur super-interface (&/$Cons super-interface stack))))) - - (.isInterface super-class) - (loop [sub-class sub-class - stack (&/|list)] - (if-let [super-interface (some valid-sub? (.getInterfaces sub-class))] - (if (= super-class super-interface) - (&/$Cons super-interface stack) - (recur super-interface (&/$Cons super-interface stack))) - (let [super* (.getSuperclass sub-class)] - (recur super* (&/$Cons super* stack))))) - - :else - (loop [sub-class sub-class - stack (&/|list)] - (let [super* (.getSuperclass sub-class)] - (if (= super* super-class) - (&/$Cons super* stack) - (recur super* (&/$Cons super* stack)))))))) - -(defn ^:private trace-lineage [^Class sub-class ^Class super-class] - "(-> Class Class (List Class))" - (if (= sub-class super-class) - (&/|list) - (&/|reverse (trace-lineage* super-class sub-class)))) - -(let [matcher (fn [m ^TypeVariable jt lt] (&/$Cons (&/T [(.getName jt) lt]) m))] - (defn ^:private match-params [sub-type-params params] - (assert (and (= (&/|length sub-type-params) (&/|length params)) - (&/|every? (partial instance? TypeVariable) sub-type-params))) - (&/fold2 matcher (&/|table) sub-type-params params))) - -;; [Exports] -(let [class-name-re #"((\[+)L([^\s]+);|([^\s]+)|(\[+)([ZBSIJFDC]))" - jprim->lprim (fn [prim] - (case prim - "Z" "boolean" - "B" "byte" - "S" "short" - "I" "int" - "J" "long" - "F" "float" - "D" "double" - "C" "char"))] - (defn class->type [^Class class] - "(-> Class Type)" - (let [gclass-name (.getName class)] - (case gclass-name - ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") - (&/$HostT gclass-name (&/|list)) - ;; else - (if-let [[_ _ arr-obrackets arr-obase simple-base arr-pbrackets arr-pbase] (re-find class-name-re gclass-name)] - (let [base (or arr-obase simple-base (jprim->lprim arr-pbase))] - (if (.equals "void" base) - &/$UnitT - (reduce (fn [inner _] (&/$HostT array-data-tag (&/|list inner))) - (&/$HostT base (try (-> (Class/forName base) .getTypeParameters - seq count (repeat (&/$HostT "java.lang.Object" &/$Nil)) - &/->list) - (catch Exception e - (&/|list)))) - (range (count (or arr-obrackets arr-pbrackets ""))))) - )))))) - -(defn instance-param [existential matchings refl-type] - "(-> (Lux Type) (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" - (cond (instance? Class refl-type) - (return (class->type refl-type)) - - (instance? GenericArrayType refl-type) - (|do [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] - (return (&/$HostT array-data-tag (&/|list inner-type)))) - - (instance? ParameterizedType refl-type) - (|do [:let [refl-type* ^ParameterizedType refl-type] - params* (->> refl-type* - .getActualTypeArguments - seq &/->list - (&/map% (partial instance-param existential matchings)))] - (return (&/$HostT (->> refl-type* ^Class (.getRawType) .getName) - params*))) - - (instance? TypeVariable refl-type) - (let [gvar (.getName ^TypeVariable refl-type)] - (if-let [m-type (&/|get gvar matchings)] - (return m-type) - (fail (str "[Type Error] Unknown generic type variable: " gvar " -- " (->> matchings - (&/|map &/|first) - &/->seq))))) - - (instance? WildcardType refl-type) - (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] - (instance-param existential matchings bound) - existential))) - -(defn principal-class [refl-type] - (cond (instance? Class refl-type) - (|case (class->type refl-type) - (&/$HostT "#Array" (&/$Cons (&/$HostT class-name _) (&/$Nil))) - (str "[" (&host-generics/->type-signature class-name)) - - (&/$HostT class-name _) - (&host-generics/->type-signature class-name) - - (&/$UnitT) - "V") - - (instance? GenericArrayType refl-type) - (&host-generics/->type-signature (str refl-type)) - - (instance? ParameterizedType refl-type) - (&host-generics/->type-signature (->> ^ParameterizedType refl-type ^Class (.getRawType) .getName)) - - (instance? TypeVariable refl-type) - (if-let [bound (->> ^TypeVariable refl-type .getBounds seq first)] - (principal-class bound) - (&host-generics/->type-signature "java.lang.Object")) - - (instance? WildcardType refl-type) - (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] - (principal-class bound) - (&host-generics/->type-signature "java.lang.Object")))) - -(defn instance-gtype [existential matchings gtype] - "(-> (Lux Type) (List (, Text Type)) GenericType (Lux Type))" - (|case gtype - (&/$GenericArray component-type) - (|do [inner-type (instance-gtype existential matchings component-type)] - (return (&/$HostT array-data-tag (&/|list inner-type)))) - - (&/$GenericClass type-name type-params) - ;; When referring to type-parameters during class or method - ;; definition, a type-environment is set for storing the names - ;; of such parameters. - ;; When a "class" shows up with the name of one of those - ;; parameters, it must be detected, and the bytecode class-name - ;; must correspond to Object's. - - (if-let [m-type (&/|get type-name matchings)] - (return m-type) - (|do [params* (&/map% (partial instance-gtype existential matchings) - type-params)] - (return (&/$HostT type-name params*)))) - - (&/$GenericTypeVar var-name) - (if-let [m-type (&/|get var-name matchings)] - (return m-type) - (fail (str "[Type Error] Unknown generic type variable: " var-name " -- " (->> matchings - (&/|map &/|first) - &/->seq)))) - - (&/$GenericWildcard) - existential)) - -;; [Utils] -(defn ^:private translate-params [existential super-type-params sub-type-params params] - "(-> (List (^ java.lang.reflect.Type)) (List (^ java.lang.reflect.Type)) (List Type) (Lux (List Type)))" - (|let [matchings (match-params sub-type-params params)] - (&/map% (partial instance-param existential matchings) super-type-params))) - -(defn ^:private raise* [existential sub+params ^Class super] - "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))" - (|let [[^Class sub params] sub+params] - (if (.isInterface super) - (|do [:let [super-params (->> sub - .getGenericInterfaces - (some #(if (= super (if (instance? Class %) % (.getRawType ^ParameterizedType %))) - (if (instance? Class %) - (&/|list) - (->> ^ParameterizedType % .getActualTypeArguments seq &/->list)) - nil)))] - params* (translate-params existential - (or super-params (&/|list)) - (->> sub .getTypeParameters seq &/->list) - params)] - (return (&/T [super params*]))) - (let [super* (.getGenericSuperclass sub)] - (cond (instance? Class super*) - (return (&/T [super* (&/|list)])) - - (instance? ParameterizedType super*) - (|do [params* (translate-params existential - (->> ^ParameterizedType super* .getActualTypeArguments seq &/->list) - (->> sub .getTypeParameters seq &/->list) - params)] - (return (&/T [super params*]))) - - :else - (assert false (prn-str super* (class super*) [sub super]))))))) - -(defn ^:private raise [existential lineage class params] - "(-> (List Class) Class (List Type) (Lux (, Class (List Type))))" - (&/fold% (partial raise* existential) (&/T [class params]) lineage)) - -;; [Exports] -(defn ->super-type [existential class-loader super-class sub-class sub-params] - "(-> Text Text (List Type) (Lux Type))" - (let [super-class+ (Class/forName super-class true class-loader) - sub-class+ (Class/forName sub-class true class-loader)] - (if (.isAssignableFrom super-class+ sub-class+) - (let [lineage (trace-lineage sub-class+ super-class+)] - (|do [[^Class sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] - (return (&/$HostT (.getName sub-class*) sub-params*)))) - (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class " super-type existential class-loader e!name a!name a!params)] - (check (&/$HostT e!name e!params) actual*)) - - :else - (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) - (catch Exception e - (prn 'check-host-types e [e!name a!name]) - (throw e))))) - -(defn gtype->gclass [gtype] - "(-> GenericType GenericClass)" - (cond (instance? Class gtype) - (&/$GenericClass (.getName ^Class gtype) &/$Nil) - - (instance? GenericArrayType gtype) - (&/$GenericArray (gtype->gclass (.getGenericComponentType ^GenericArrayType gtype))) - - (instance? ParameterizedType gtype) - (let [type-name (->> ^ParameterizedType gtype ^Class (.getRawType) .getName) - type-params (->> ^ParameterizedType gtype - .getActualTypeArguments - seq &/->list - (&/|map gtype->gclass))] - (&/$GenericClass type-name type-params)) - - (instance? TypeVariable gtype) - (&/$GenericTypeVar (.getName ^TypeVariable gtype)) - - (instance? WildcardType gtype) - (if-let [bound (->> ^WildcardType gtype .getUpperBounds seq first)] - (&/$GenericWildcard (&/$Some (&/T &/$UpperBound (gtype->gclass bound)))) - (if-let [bound (->> ^WildcardType gtype .getLowerBounds seq first)] - (&/$GenericWildcard (&/$Some (&/T &/$LowerBound (gtype->gclass bound)))) - (&/$GenericWildcard &/$None))))) - -(let [generic-type-sig "Ljava/lang/Object;"] - (defn gclass->sig [gclass] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericClass gclass-name (&/$Nil)) - (case gclass-name - "void" "V" - "boolean" "Z" - "byte" "B" - "short" "S" - "int" "I" - "long" "J" - "float" "F" - "double" "D" - "char" "C" - ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") gclass-name - ;; else - (str "L" (clojure.string/replace gclass-name #"\." "/") ";")) - - (&/$GenericArray inner-gtype) - (str "[" (gclass->sig inner-gtype)) - - (&/$GenericTypeVar ?vname) - generic-type-sig - - (&/$GenericWildcard _) - generic-type-sig - ))) diff --git a/stdlib/README.md b/stdlib/README.md new file mode 100644 index 000000000..454228d07 --- /dev/null +++ b/stdlib/README.md @@ -0,0 +1,15 @@ +# stdlib +Standard library for the Lux family of programming languages. + +### How do I get it? + +Just add this to your Leiningen dependencies when building Lux programs: +``` +[com.github.luxlang/lux-stdlib "0.3.3"] +``` + +You can find the Leiningen plugin for Lux over here: https://github.com/LuxLang/lux-lein + +### How do I use it? + +You can see what's available here: https://github.com/LuxLang/lux/wiki/Standard-Library diff --git a/stdlib/license.txt b/stdlib/license.txt new file mode 100644 index 000000000..52d135112 --- /dev/null +++ b/stdlib/license.txt @@ -0,0 +1,374 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. + diff --git a/stdlib/project.clj b/stdlib/project.clj new file mode 100644 index 000000000..287a2f803 --- /dev/null +++ b/stdlib/project.clj @@ -0,0 +1,19 @@ +(defproject com.github.luxlang/lux-stdlib "0.5.0-SNAPSHOT" + :description "Standard library for the Lux programming language." + :url "https://github.com/LuxLang/stdlib" + :license {:name "Mozilla Public License (Version 2.0)" + :url "https://www.mozilla.org/en-US/MPL/2.0/"} + :plugins [[com.github.luxlang/lein-luxc "0.5.0-SNAPSHOT"]] + :deploy-repositories [["releases" {:url "https://oss.sonatype.org/service/local/staging/deploy/maven2/" + :creds :gpg}] + ["snapshots" {:url "https://oss.sonatype.org/content/repositories/snapshots/" + :creds :gpg}]] + :pom-addition [:developers [:developer + [:name "Eduardo Julian"] + [:url "https://github.com/eduardoejp"]]] + :repositories [["snapshots" "https://oss.sonatype.org/content/repositories/snapshots/"] + ["releases" "https://oss.sonatype.org/service/local/staging/deploy/maven2/"]] + :source-paths ["source"] + :test-paths ["test"] + :lux {:tests "tests"} + ) diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux new file mode 100644 index 000000000..2b66cdbe1 --- /dev/null +++ b/stdlib/source/lux.lux @@ -0,0 +1,5541 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +## Basic types +(_lux_def Bool + (+12 ["lux" "Bool"] + (+0 "java.lang.Boolean" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Nat + (+12 ["lux" "Nat"] + (+0 "#Nat" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Int + (+12 ["lux" "Int"] + (+0 "java.lang.Long" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Real + (+12 ["lux" "Real"] + (+0 "java.lang.Double" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Frac + (+12 ["lux" "Frac"] + (+0 "#Frac" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Char + (+12 ["lux" "Char"] + (+0 "java.lang.Character" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Text + (+12 ["lux" "Text"] + (+0 "java.lang.String" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Void + (+12 ["lux" "Void"] + (+1)) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Unit + (+12 ["lux" "Unit"] + (+2)) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Ident + (+12 ["lux" "Ident"] + (+4 Text Text)) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +## (type: (List a) +## #Nil +## (#Cons a (List a))) +(_lux_def List + (+12 ["lux" "List"] + (+9 (+0) + (+3 ## "lux;Nil" + (+2) + ## "lux;Cons" + (+4 (+6 +1) + (+11 (+6 +0) (+6 +1)))))) + (+1 [["lux" "type?"] (+0 true)] + (+1 [["lux" "export?"] (+0 true)] + (+1 [["lux" "tags"] (+8 (+1 (+6 "Nil") (+1 (+6 "Cons") (+0))))] + (+1 [["lux" "type-args"] (+8 (+1 (+6 "a") (+0)))] + (+0)))))) + +## (type: (Maybe a) +## #None +## (#Some a)) +(_lux_def Maybe + (+12 ["lux" "Maybe"] + (+9 (+0) + (+3 ## "lux;None" + (+2) + ## "lux;Some" + (+6 +1)))) + (#Cons [["lux" "type?"] (+0 true)] + (#Cons [["lux" "export?"] (+0 true)] + (#Cons [["lux" "tags"] (+8 (#Cons (+6 "None") (#Cons (+6 "Some") #Nil)))] + (#Cons [["lux" "type-args"] (+8 (#Cons (+6 "a") #Nil))] + #Nil))))) + +## (type: #rec Type +## (#HostT Text (List Type)) +## #VoidT +## #UnitT +## (#SumT Type Type) +## (#ProdT Type Type) +## (#LambdaT Type Type) +## (#BoundT Nat) +## (#VarT Nat) +## (#ExT Nat) +## (#UnivQ (List Type) Type) +## (#ExQ (List Type) Type) +## (#AppT Type Type) +## (#NamedT Ident Type) +## ) +(_lux_def Type + (+12 ["lux" "Type"] + (_lux_case (+11 (+6 +0) (+6 +1)) + Type + (_lux_case (+11 List Type) + TypeList + (_lux_case (+4 Type Type) + TypePair + (+11 (+9 (+0) + (+3 ## "lux;HostT" + (+4 Text TypeList) + (+3 ## "lux;VoidT" + (+2) + (+3 ## "lux;UnitT" + (+2) + (+3 ## "lux;SumT" + TypePair + (+3 ## "lux;ProdT" + TypePair + (+3 ## "lux;LambdaT" + TypePair + (+3 ## "lux;BoundT" + Nat + (+3 ## "lux;VarT" + Nat + (+3 ## "lux;ExT" + Nat + (+3 ## "lux;UnivQ" + (+4 TypeList Type) + (+3 ## "lux;ExQ" + (+4 TypeList Type) + (+3 ## "lux;AppT" + TypePair + ## "lux;NamedT" + (+4 Ident Type)))))))))))))) + Void))))) + (#Cons [["lux" "type?"] (+0 true)] + (#Cons [["lux" "export?"] (+0 true)] + (#Cons [["lux" "tags"] (+8 (#Cons (+6 "HostT") + (#Cons (+6 "VoidT") + (#Cons (+6 "UnitT") + (#Cons (+6 "SumT") + (#Cons (+6 "ProdT") + (#Cons (+6 "LambdaT") + (#Cons (+6 "BoundT") + (#Cons (+6 "VarT") + (#Cons (+6 "ExT") + (#Cons (+6 "UnivQ") + (#Cons (+6 "ExQ") + (#Cons (+6 "AppT") + (#Cons (+6 "NamedT") + #Nil))))))))))))))] + (#Cons [["lux" "doc"] (+6 "This type represents the data-structures that are used to specify types themselves.")] + (#Cons [["lux" "type-rec?"] (+0 true)] + #Nil)))))) + +## (type: Top +## (Ex [a] a)) +(_lux_def Top + (#NamedT ["lux" "Top"] + (#ExQ (+0) (#BoundT +1))) + (#Cons [["lux" "type?"] (+0 true)] + (#Cons [["lux" "export?"] (+0 true)] + (#Cons [["lux" "doc"] (+6 "The type of things whose type doesn't matter. + It can be used to write functions or data-structures that can take, or return anything.")] + #Nil)))) + +## (type: Bottom +## (All [a] a)) +(_lux_def Bottom + (#NamedT ["lux" "Bottom"] + (#UnivQ (+0) (#BoundT +1))) + (#Cons [["lux" "type?"] (+0 true)] + (#Cons [["lux" "export?"] (+0 true)] + (#Cons [["lux" "doc"] (+6 "The type of things whose type is unknown or undefined. + Useful for expressions that cause errors or other \"extraordinary\" conditions.")] + #Nil)))) + +## (type: #rec Ann-Value +## (#BoolM Bool) +## (#NatM Nat) +## (#IntM Int) +## (#FracM Frac) +## (#RealM Real) +## (#CharM Char) +## (#TextM Text) +## (#IdentM Ident) +## (#ListM (List Ann-Value)) +## (#DictM (List [Text Ann-Value]))) +(_lux_def Ann-Value + (#NamedT ["lux" "Ann-Value"] + (_lux_case (#AppT (#BoundT +0) (#BoundT +1)) + Ann-Value + (#AppT (#UnivQ #Nil + (#SumT ## #BoolM + Bool + (#SumT ## #NatM + Nat + (#SumT ## #IntM + Int + (#SumT ## #FracM + Frac + (#SumT ## #RealM + Real + (#SumT ## #CharM + Char + (#SumT ## #TextM + Text + (#SumT ## #IdentM + Ident + (#SumT ## #ListM + (#AppT List Ann-Value) + ## #DictM + (#AppT List (#ProdT Text Ann-Value))))))))))) + ) + Void) + )) + (#Cons [["lux" "type?"] (+0 true)] + (#Cons [["lux" "export?"] (+0 true)] + (#Cons [["lux" "tags"] (+8 (#Cons (+6 "BoolM") + (#Cons (+6 "NatM") + (#Cons (+6 "IntM") + (#Cons (+6 "FracM") + (#Cons (+6 "RealM") + (#Cons (+6 "CharM") + (#Cons (+6 "TextM") + (#Cons (+6 "IdentM") + (#Cons (+6 "ListM") + (#Cons (+6 "DictM") + #Nil)))))))))))] + (#Cons [["lux" "type-rec?"] (+0 true)] + #Nil))))) + +## (type: Anns +## (List [Ident Ann-Value])) +(_lux_def Anns + (#NamedT ["lux" "Anns"] + (#AppT List (#ProdT Ident Ann-Value))) + (#Cons [["lux" "type?"] (#BoolM true)] + (#Cons [["lux" "export?"] (#BoolM true)] + #Nil))) + +(_lux_def default-def-meta-exported + (_lux_: Anns + (#Cons [["lux" "type?"] (#BoolM true)] + (#Cons [["lux" "export?"] (#BoolM true)] + #Nil))) + #Nil) + +(_lux_def default-def-meta-unexported + (_lux_: Anns + (#Cons [["lux" "type?"] (#BoolM true)] + #Nil)) + #Nil) + +## (type: Def +## [Type Anns Unit]) +(_lux_def Def + (#NamedT ["lux" "Def"] + (#ProdT Type (#ProdT Anns Unit))) + default-def-meta-exported) + +## (type: (Bindings k v) +## {#counter Nat +## #mappings (List [k v])}) +(_lux_def Bindings + (#NamedT ["lux" "Bindings"] + (#UnivQ #Nil + (#UnivQ #Nil + (#ProdT ## "lux;counter" + Nat + ## "lux;mappings" + (#AppT List + (#ProdT (#BoundT +3) + (#BoundT +1))))))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "counter") + (#Cons (#TextM "mappings") + #Nil)))] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "k") (#Cons (#TextM "v") #;Nil)))] + default-def-meta-exported))) + +## (type: Cursor +## {#module Text +## #line Int +## #column Int}) +(_lux_def Cursor + (#NamedT ["lux" "Cursor"] + (#ProdT Text (#ProdT Int Int))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "module") + (#Cons (#TextM "line") + (#Cons (#TextM "column") + #Nil))))] + (#Cons [["lux" "doc"] (#TextM "Cursors are for specifying the location of AST nodes in Lux files during compilation.")] + default-def-meta-exported))) + +## (type: (Meta m v) +## {#meta m +## #datum v}) +(_lux_def Meta + (#NamedT ["lux" "Meta"] + (#UnivQ #Nil + (#UnivQ #Nil + (#ProdT (#BoundT +3) + (#BoundT +1))))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "meta") + (#Cons (#TextM "datum") + #Nil)))] + (#Cons [["lux" "doc"] (#TextM "The type of things that can have meta-data of arbitrary types.")] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "m") (#Cons (#TextM "v") #;Nil)))] + default-def-meta-exported)))) + +(_lux_def Analysis + (#NamedT ["lux" "Analysis"] + (#AppT (#AppT Meta + (#ProdT Type Cursor)) + Void)) + default-def-meta-exported) + +## (type: Scope +## {#name (List Text) +## #inner-closures Int +## #locals (Bindings Text Analysis) +## #closure (Bindings Text Analysis)}) +(_lux_def Scope + (#NamedT ["lux" "Scope"] + (#ProdT ## "lux;name" + (#AppT List Text) + (#ProdT ## "lux;inner-closures" + Int + (#ProdT ## "lux;locals" + (#AppT (#AppT Bindings Text) Analysis) + ## "lux;closure" + (#AppT (#AppT Bindings Text) Analysis))))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "name") + (#Cons (#TextM "inner-closures") + (#Cons (#TextM "locals") + (#Cons (#TextM "closure") + #Nil)))))] + default-def-meta-exported)) + +## (type: (AST' w) +## (#BoolS Bool) +## (#NatS Nat) +## (#IntS Int) +## (#FracS Frac) +## (#RealS Real) +## (#CharS Char) +## (#TextS Text) +## (#SymbolS Text Text) +## (#TagS Text Text) +## (#FormS (List (w (AST' w)))) +## (#TupleS (List (w (AST' w)))) +## (#RecordS (List [(w (AST' w)) (w (AST' w))]))) +(_lux_def AST' + (#NamedT ["lux" "AST'"] + (_lux_case (#AppT (#BoundT +1) + (#AppT (#BoundT +0) + (#BoundT +1))) + AST + (_lux_case (#AppT [List AST]) + ASTList + (#UnivQ #Nil + (#SumT ## "lux;BoolS" + Bool + (#SumT ## "lux;NatS" + Nat + (#SumT ## "lux;IntS" + Int + (#SumT ## "lux;FracS" + Frac + (#SumT ## "lux;RealS" + Real + (#SumT ## "lux;CharS" + Char + (#SumT ## "lux;TextS" + Text + (#SumT ## "lux;SymbolS" + Ident + (#SumT ## "lux;TagS" + Ident + (#SumT ## "lux;FormS" + ASTList + (#SumT ## "lux;TupleS" + ASTList + ## "lux;RecordS" + (#AppT List (#ProdT AST AST)) + ))))))))))) + )))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "BoolS") + (#Cons (#TextM "NatS") + (#Cons (#TextM "IntS") + (#Cons (#TextM "FracS") + (#Cons (#TextM "RealS") + (#Cons (#TextM "CharS") + (#Cons (#TextM "TextS") + (#Cons (#TextM "SymbolS") + (#Cons (#TextM "TagS") + (#Cons (#TextM "FormS") + (#Cons (#TextM "TupleS") + (#Cons (#TextM "RecordS") + #Nil)))))))))))))] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "w") #;Nil))] + default-def-meta-exported))) + +## (type: AST +## (Meta Cursor (AST' (Meta Cursor)))) +(_lux_def AST + (#NamedT ["lux" "AST"] + (_lux_case (#AppT Meta Cursor) + w + (#AppT w (#AppT AST' w)))) + (#Cons [["lux" "doc"] (#TextM "The type of AST nodes for Lux syntax.")] + default-def-meta-exported)) + +(_lux_def ASTList + (#AppT List AST) + default-def-meta-unexported) + +## (type: (Either l r) +## (#Left l) +## (#Right r)) +(_lux_def Either + (#NamedT ["lux" "Either"] + (#UnivQ #Nil + (#UnivQ #Nil + (#SumT ## "lux;Left" + (#BoundT +3) + ## "lux;Right" + (#BoundT +1))))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "Left") + (#Cons (#TextM "Right") + #Nil)))] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "l") (#Cons (#TextM "r") #;Nil)))] + default-def-meta-exported))) + +## (type: Source +## (List (Meta Cursor Text))) +(_lux_def Source + (#NamedT ["lux" "Source"] + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])])) + default-def-meta-exported) + +## (type: Module +## {#module-hash Int +## #module-aliases (List [Text Text]) +## #defs (List [Text Def]) +## #imports (List Text) +## #tags (List [Text [Nat (List Ident) Bool Type]]) +## #types (List [Text [(List Ident) Bool Type]])} +## #module-anns Anns +## ) +(_lux_def Module + (#NamedT ["lux" "Module"] + (#ProdT ## "lux;module-hash" + Int + (#ProdT ## "lux;module-aliases" + (#AppT List (#ProdT Text Text)) + (#ProdT ## "lux;defs" + (#AppT List (#ProdT Text + Def)) + (#ProdT ## "lux;imports" + (#AppT List Text) + (#ProdT ## "lux;tags" + (#AppT List + (#ProdT Text + (#ProdT Nat + (#ProdT (#AppT List Ident) + (#ProdT Bool + Type))))) + (#ProdT ## "lux;types" + (#AppT List + (#ProdT Text + (#ProdT (#AppT List Ident) + (#ProdT Bool + Type)))) + ## "lux;module-anns" + Anns) + )))))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "module-hash") + (#Cons (#TextM "module-aliases") + (#Cons (#TextM "defs") + (#Cons (#TextM "imports") + (#Cons (#TextM "tags") + (#Cons (#TextM "types") + (#Cons (#TextM "module-anns") + #Nil))))))))] + default-def-meta-exported)) + +## (type: CompilerMode +## #Release +## #Debug +## #Eval +## #REPL) +(_lux_def CompilerMode + (#NamedT ["lux" "CompilerMode"] + (#SumT ## "lux;Release" + #UnitT + (#SumT ## "lux;Debug" + #UnitT + (#SumT ## "lux;Eval" + #UnitT + ## "lux;REPL" + #UnitT)))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "Release") + (#Cons (#TextM "Debug") + (#Cons (#TextM "Eval") + (#Cons (#TextM "REPL") + #Nil)))))] + default-def-meta-exported)) + +## (type: CompilerInfo +## {#compiler-name Text +## #compiler-version Text +## #compiler-mode CompilerMode}) +(_lux_def CompilerInfo + (#NamedT ["lux" "CompilerInfo"] + (#ProdT ## "lux;compiler-name" + Text + (#ProdT ## "lux;compiler-version" + Text + ## "lux;compiler-mode" + CompilerMode))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "compiler-name") + (#Cons (#TextM "compiler-version") + (#Cons (#TextM "compiler-mode") + #Nil))))] + default-def-meta-exported)) + +## (type: Compiler +## {#info CompilerInfo +## #source Source +## #cursor Cursor +## #modules (List [Text Module]) +## #scopes (List Scope) +## #type-vars (Bindings Nat (Maybe Type)) +## #expected (Maybe Type) +## #seed Nat +## #scope-type-vars (List Nat) +## #host Void}) +(_lux_def Compiler + (#NamedT ["lux" "Compiler"] + (#ProdT ## "lux;info" + CompilerInfo + (#ProdT ## "lux;source" + Source + (#ProdT ## "lux;cursor" + Cursor + (#ProdT ## "lux;modules" + (#AppT List (#ProdT Text + Module)) + (#ProdT ## "lux;scopes" + (#AppT List Scope) + (#ProdT ## "lux;type-vars" + (#AppT (#AppT Bindings Nat) (#AppT Maybe Type)) + (#ProdT ## "lux;expected" + (#AppT Maybe Type) + (#ProdT ## "lux;seed" + Nat + (#ProdT ## "lux;scope-type-vars" + (#AppT List Nat) + ## "lux;host" + Void)))))))))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "info") + (#Cons (#TextM "source") + (#Cons (#TextM "cursor") + (#Cons (#TextM "modules") + (#Cons (#TextM "scopes") + (#Cons (#TextM "type-vars") + (#Cons (#TextM "expected") + (#Cons (#TextM "seed") + (#Cons (#TextM "scope-type-vars") + (#Cons (#TextM "host") + #Nil)))))))))))] + (#Cons [["lux" "doc"] (#TextM "Represents the state of the Lux compiler during a run. + It's provided to macros during their invocation, so they can access compiler data. + + Caveat emptor: Avoid fiddling with it, unless you know what you're doing.")] + default-def-meta-exported))) + +## (type: (Lux a) +## (-> Compiler (Either Text [Compiler a]))) +(_lux_def Lux + (#NamedT ["lux" "Lux"] + (#UnivQ #Nil + (#LambdaT Compiler + (#AppT (#AppT Either Text) + (#ProdT Compiler (#BoundT +1)))))) + (#Cons [["lux" "doc"] (#TextM "Computations that can have access to the state of the compiler. + Those computations may also fail, or modify the state of the compiler.")] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "a") #;Nil))] + default-def-meta-exported))) + +## (type: Macro +## (-> (List AST) (Lux (List AST)))) +(_lux_def Macro + (#NamedT ["lux" "Macro"] + (#LambdaT ASTList (#AppT Lux ASTList))) + default-def-meta-exported) + +## Base functions & macros +## (def: _cursor +## Cursor +## ["" -1 -1]) +(_lux_def _cursor + (_lux_: Cursor ["" -1 -1]) + #Nil) + +## (def: (_meta data) +## (-> (AST' (Meta Cursor)) AST) +## [["" -1 -1] data]) +(_lux_def _meta + (_lux_: (#LambdaT (#AppT AST' + (#AppT Meta Cursor)) + AST) + (_lux_lambda _ data + [_cursor data])) + #Nil) + +## (def: (return x) +## (All [a] +## (-> a Compiler +## (Either Text [Compiler a]))) +## ...) +(_lux_def return + (_lux_: (#UnivQ #Nil + (#LambdaT (#BoundT +1) + (#LambdaT Compiler + (#AppT (#AppT Either Text) + (#ProdT Compiler + (#BoundT +1)))))) + (_lux_lambda _ val + (_lux_lambda _ state + (#Right state val)))) + #Nil) + +## (def: (fail msg) +## (All [a] +## (-> Text Compiler +## (Either Text [Compiler a]))) +## ...) +(_lux_def fail + (_lux_: (#UnivQ #Nil + (#LambdaT Text + (#LambdaT Compiler + (#AppT (#AppT Either Text) + (#ProdT Compiler + (#BoundT +1)))))) + (_lux_lambda _ msg + (_lux_lambda _ state + (#Left msg)))) + #Nil) + +(_lux_def bool$ + (_lux_: (#LambdaT Bool AST) + (_lux_lambda _ value (_meta (#BoolS value)))) + #Nil) + +(_lux_def nat$ + (_lux_: (#LambdaT Nat AST) + (_lux_lambda _ value (_meta (#NatS value)))) + #Nil) + +(_lux_def int$ + (_lux_: (#LambdaT Int AST) + (_lux_lambda _ value (_meta (#IntS value)))) + #Nil) + +(_lux_def frac$ + (_lux_: (#LambdaT Frac AST) + (_lux_lambda _ value (_meta (#FracS value)))) + #Nil) + +(_lux_def real$ + (_lux_: (#LambdaT Real AST) + (_lux_lambda _ value (_meta (#RealS value)))) + #Nil) + +(_lux_def char$ + (_lux_: (#LambdaT Char AST) + (_lux_lambda _ value (_meta (#CharS value)))) + #Nil) + +(_lux_def text$ + (_lux_: (#LambdaT Text AST) + (_lux_lambda _ text (_meta (#TextS text)))) + #Nil) + +(_lux_def symbol$ + (_lux_: (#LambdaT Ident AST) + (_lux_lambda _ ident (_meta (#SymbolS ident)))) + #Nil) + +(_lux_def tag$ + (_lux_: (#LambdaT Ident AST) + (_lux_lambda _ ident (_meta (#TagS ident)))) + #Nil) + +(_lux_def form$ + (_lux_: (#LambdaT (#AppT List AST) AST) + (_lux_lambda _ tokens (_meta (#FormS tokens)))) + #Nil) + +(_lux_def tuple$ + (_lux_: (#LambdaT (#AppT List AST) AST) + (_lux_lambda _ tokens (_meta (#TupleS tokens)))) + #Nil) + +(_lux_def record$ + (_lux_: (#LambdaT (#AppT List (#ProdT AST AST)) AST) + (_lux_lambda _ tokens (_meta (#RecordS tokens)))) + #Nil) + +(_lux_def default-macro-meta + (_lux_: Anns + (#Cons [["lux" "macro?"] (#BoolM true)] + #Nil)) + #Nil) + +(_lux_def let'' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons lhs (#Cons rhs (#Cons body #Nil))) + (return (#Cons (form$ (#Cons (symbol$ ["" "_lux_case"]) + (#Cons rhs (#Cons lhs (#Cons body #Nil))))) + #Nil)) + + _ + (fail "Wrong syntax for let''")))) + default-macro-meta) + +(_lux_def lambda'' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)) + (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) + (#Cons (_meta (#SymbolS "" "")) + (#Cons arg + (#Cons (_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''")) + (#Cons (_meta (#TupleS args')) + (#Cons body #Nil)))))) + #Nil)))))) + #Nil)) + + (#Cons [_ (#SymbolS "" self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))) + (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) + (#Cons (_meta (#SymbolS "" self)) + (#Cons arg + (#Cons (_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''")) + (#Cons (_meta (#TupleS args')) + (#Cons body #Nil)))))) + #Nil)))))) + #Nil)) + + _ + (fail "Wrong syntax for lambda''")))) + default-macro-meta) + +(_lux_def export?-meta + (_lux_: AST + (tuple$ (#Cons [(tuple$ (#Cons [(text$ "lux") (#Cons [(text$ "export?") #Nil])])) + (#Cons [(form$ (#Cons [(tag$ ["lux" "BoolM"]) + (#Cons [(bool$ true) + #Nil])])) + #Nil])]))) + #Nil) + +(_lux_def hidden?-meta + (_lux_: AST + (tuple$ (#Cons [(tuple$ (#Cons [(text$ "lux") (#Cons [(text$ "hidden?") #Nil])])) + (#Cons [(form$ (#Cons [(tag$ ["lux" "BoolM"]) + (#Cons [(bool$ true) + #Nil])])) + #Nil])]))) + #Nil) + +(_lux_def macro?-meta + (_lux_: AST + (tuple$ (#Cons [(tuple$ (#Cons [(text$ "lux") (#Cons [(text$ "macro?") #Nil])])) + (#Cons [(form$ (#Cons [(tag$ ["lux" "BoolM"]) + (#Cons [(bool$ true) + #Nil])])) + #Nil])]))) + #Nil) + +(_lux_def with-export-meta + (_lux_: (#LambdaT AST AST) + (lambda'' [tail] + (form$ (#Cons (tag$ ["lux" "Cons"]) + (#Cons export?-meta + (#Cons tail #Nil)))))) + #Nil) + +(_lux_def with-hidden-meta + (_lux_: (#LambdaT AST AST) + (lambda'' [tail] + (form$ (#Cons (tag$ ["lux" "Cons"]) + (#Cons hidden?-meta + (#Cons tail #Nil)))))) + #Nil) + +(_lux_def with-macro-meta + (_lux_: (#LambdaT AST AST) + (lambda'' [tail] + (form$ (#Cons (tag$ ["lux" "Cons"]) + (#Cons macro?-meta + (#Cons tail #Nil)))))) + #Nil) + +(_lux_def def:'' + (_lux_: Macro + (lambda'' [tokens] + (_lux_case tokens + (#Cons [[_ (#TagS ["" "export"])] + (#Cons [[_ (#FormS (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + (#Cons (with-export-meta meta) #Nil)])])]))) + #Nil])) + + (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + (#Cons (with-export-meta meta) #Nil)])])]))) + #Nil])) + + (#Cons [[_ (#FormS (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + (#Cons meta #Nil)])])]))) + #Nil])) + + (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + (#Cons meta #Nil)])])]))) + #Nil])) + + _ + (fail "Wrong syntax for def''")) + )) + default-macro-meta) + +(def:'' (macro:' tokens) + default-macro-meta + Macro + (_lux_case tokens + (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil)) + (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"]) + (#Cons (form$ (#Cons name args)) + (#Cons (with-macro-meta (tag$ ["lux" "Nil"])) + (#Cons (symbol$ ["lux" "Macro"]) + (#Cons body + #Nil))) + ))) + #Nil)) + + (#Cons [_ (#TagS ["" "export"])] (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil))) + (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"]) + (#Cons (tag$ ["" "export"]) + (#Cons (form$ (#Cons name args)) + (#Cons (with-macro-meta (tag$ ["lux" "Nil"])) + (#Cons (symbol$ ["lux" "Macro"]) + (#Cons body + #Nil))) + )))) + #Nil)) + + (#Cons [_ (#TagS ["" "export"])] (#Cons [_ (#FormS (#Cons name args))] (#Cons meta-data (#Cons body #Nil)))) + (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"]) + (#Cons (tag$ ["" "export"]) + (#Cons (form$ (#Cons name args)) + (#Cons (with-macro-meta meta-data) + (#Cons (symbol$ ["lux" "Macro"]) + (#Cons body + #Nil))) + )))) + #Nil)) + + _ + (fail "Wrong syntax for macro:'"))) + +(macro:' #export (comment tokens) + (#Cons [["lux" "doc"] (#TextM "## Throws away any code given to it. + ## Great for commenting out code, while retaining syntax high-lightning and formatting in your text editor. + (comment 1 2 3 4)")] + #;Nil) + (return #Nil)) + +(macro:' ($' tokens) + (_lux_case tokens + (#Cons x #Nil) + (return tokens) + + (#Cons x (#Cons y xs)) + (return (#Cons (form$ (#Cons (symbol$ ["lux" "$'"]) + (#Cons (form$ (#Cons (tag$ ["lux" "AppT"]) + (#Cons x (#Cons y #Nil)))) + xs))) + #Nil)) + + _ + (fail "Wrong syntax for $'"))) + +(def:'' (map f xs) + #Nil + (#UnivQ #Nil + (#UnivQ #Nil + (#LambdaT (#LambdaT (#BoundT +3) (#BoundT +1)) + (#LambdaT ($' List (#BoundT +3)) + ($' List (#BoundT +1)))))) + (_lux_case xs + #Nil + #Nil + + (#Cons x xs') + (#Cons (f x) (map f xs')))) + +(def:'' RepEnv + #Nil + Type + ($' List (#ProdT Text AST))) + +(def:'' (make-env xs ys) + #Nil + (#LambdaT ($' List Text) (#LambdaT ($' List AST) RepEnv)) + (_lux_case [xs ys] + [(#Cons x xs') (#Cons y ys')] + (#Cons [x y] (make-env xs' ys')) + + _ + #Nil)) + +(def:'' (Text/= x y) + #Nil + (#LambdaT Text (#LambdaT Text Bool)) + (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [x y])) + +(def:'' (get-rep key env) + #Nil + (#LambdaT Text (#LambdaT RepEnv ($' Maybe AST))) + (_lux_case env + #Nil + #None + + (#Cons [k v] env') + (_lux_case (Text/= k key) + true + (#Some v) + + false + (get-rep key env')))) + +(def:'' (replace-syntax reps syntax) + #Nil + (#LambdaT RepEnv (#LambdaT AST AST)) + (_lux_case syntax + [_ (#SymbolS "" name)] + (_lux_case (get-rep name reps) + (#Some replacement) + replacement + + #None + syntax) + + [meta (#FormS parts)] + [meta (#FormS (map (replace-syntax reps) parts))] + + [meta (#TupleS members)] + [meta (#TupleS (map (replace-syntax reps) members))] + + [meta (#RecordS slots)] + [meta (#RecordS (map (_lux_: (#LambdaT (#ProdT AST AST) (#ProdT AST AST)) + (lambda'' [slot] + (_lux_case slot + [k v] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))] + + _ + syntax) + ) + +(def:'' (update-bounds ast) + #Nil + (#LambdaT AST AST) + (_lux_case ast + [_ (#TupleS members)] + (tuple$ (map update-bounds members)) + + [_ (#RecordS pairs)] + (record$ (map (_lux_: (#LambdaT (#ProdT AST AST) (#ProdT AST AST)) + (lambda'' [pair] + (let'' [name val] pair + [name (update-bounds val)]))) + pairs)) + + [_ (#FormS (#Cons [_ (#TagS "lux" "BoundT")] (#Cons [_ (#NatS idx)] #Nil)))] + (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (nat$ (_lux_proc ["nat" "+"] [+2 idx])) #Nil))) + + [_ (#FormS members)] + (form$ (map update-bounds members)) + + _ + ast)) + +(def:'' (parse-quantified-args args next) + #Nil + ## (-> (List AST) (-> (List Text) (Lux (List AST))) (Lux (List AST))) + (#LambdaT ($' List AST) + (#LambdaT (#LambdaT ($' List Text) (#AppT Lux ($' List AST))) + (#AppT Lux ($' List AST)) + )) + (_lux_case args + #Nil + (next #Nil) + + (#Cons [_ (#SymbolS "" arg-name)] args') + (parse-quantified-args args' (lambda'' [names] (next (#Cons arg-name names)))) + + _ + (fail "Expected symbol.") + )) + +(def:'' (make-bound idx) + #Nil + (#LambdaT Nat AST) + (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (nat$ idx) #Nil)))) + +(def:'' (fold f init xs) + #Nil + ## (All [a b] (-> (-> b a a) a (List b) a)) + (#UnivQ #Nil (#UnivQ #Nil (#LambdaT (#LambdaT (#BoundT +1) + (#LambdaT (#BoundT +3) + (#BoundT +3))) + (#LambdaT (#BoundT +3) + (#LambdaT ($' List (#BoundT +1)) + (#BoundT +3)))))) + (_lux_case xs + #Nil + init + + (#Cons x xs') + (fold f (f x init) xs'))) + +(def:'' (length list) + #Nil + (#UnivQ #Nil + (#LambdaT ($' List (#BoundT +1)) Int)) + (fold (lambda'' [_ acc] (_lux_proc ["jvm" "ladd"] [1 acc])) 0 list)) + +(macro:' #export (All tokens) + (#Cons [["lux" "doc"] (#TextM "## Universal quantification. + (All [a] + (-> a a)) + + ## A name can be provided, to specify a recursive type. + (All List [a] + (| Unit + [a (List a)]))")] + #;Nil) + (let'' [self-name tokens] (_lux_case tokens + (#Cons [_ (#SymbolS "" self-name)] tokens) + [self-name tokens] + + _ + ["" tokens]) + (_lux_case tokens + (#Cons [_ (#TupleS args)] (#Cons body #Nil)) + (parse-quantified-args args + (lambda'' [names] + (let'' body' (fold (_lux_: (#LambdaT Text (#LambdaT AST AST)) + (lambda'' [name' body'] + (form$ (#Cons (tag$ ["lux" "UnivQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) + (update-bounds body')) #Nil)))))) + body + names) + (return (#Cons (_lux_case [(Text/= "" self-name) names] + [true _] + body' + + [_ #;Nil] + body' + + [false _] + (replace-syntax (#Cons [self-name (make-bound (_lux_proc ["nat" "*"] + [+2 (_lux_proc ["nat" "-"] + [(_lux_proc ["int" "to-nat"] + [(length names)]) + +1])]))] + #Nil) + body')) + #Nil))))) + + _ + (fail "Wrong syntax for All")) + )) + +(macro:' #export (Ex tokens) + (#Cons [["lux" "doc"] (#TextM "## Existential quantification. + (Ex [a] + [(Codec Text a) + a]) + + ## A name can be provided, to specify a recursive type. + (Ex Self [a] + [(Codec Text a) + a + (List (Self a))])")] + #;Nil) + (let'' [self-name tokens] (_lux_case tokens + (#Cons [_ (#SymbolS "" self-name)] tokens) + [self-name tokens] + + _ + ["" tokens]) + (_lux_case tokens + (#Cons [_ (#TupleS args)] (#Cons body #Nil)) + (parse-quantified-args args + (lambda'' [names] + (let'' body' (fold (_lux_: (#LambdaT Text (#LambdaT AST AST)) + (lambda'' [name' body'] + (form$ (#Cons (tag$ ["lux" "ExQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) + (update-bounds body')) #Nil)))))) + body + names) + (return (#Cons (_lux_case [(Text/= "" self-name) names] + [true _] + body' + + [_ #;Nil] + body' + + [false _] + (replace-syntax (#Cons [self-name (make-bound (_lux_proc ["nat" "*"] + [+2 (_lux_proc ["nat" "-"] + [(_lux_proc ["int" "to-nat"] + [(length names)]) + +1])]))] + #Nil) + body')) + #Nil))))) + + _ + (fail "Wrong syntax for Ex")) + )) + +(def:'' (reverse list) + #Nil + (All [a] (#LambdaT ($' List a) ($' List a))) + (fold (lambda'' [head tail] (#Cons head tail)) + #Nil + list)) + +(macro:' #export (-> tokens) + (#Cons [["lux" "doc"] (#TextM "## Function types: + (-> Int Int Int) + + ## This is the type of a function that takes 2 Ints and returns an Int.")] + #;Nil) + (_lux_case (reverse tokens) + (#Cons output inputs) + (return (#Cons (fold (_lux_: (#LambdaT AST (#LambdaT AST AST)) + (lambda'' [i o] (form$ (#Cons (tag$ ["lux" "LambdaT"]) (#Cons i (#Cons o #Nil)))))) + output + inputs) + #Nil)) + + _ + (fail "Wrong syntax for ->"))) + +(macro:' #export (list xs) + (#Cons [["lux" "doc"] (#TextM "## List-construction macro. + (list 1 2 3)")] + #;Nil) + (return (#Cons (fold (lambda'' [head tail] + (form$ (#Cons (tag$ ["lux" "Cons"]) + (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) + #Nil)))) + (tag$ ["lux" "Nil"]) + (reverse xs)) + #Nil))) + +(macro:' #export (list& xs) + (#Cons [["lux" "doc"] (#TextM "## List-construction macro, with the last element being a tail-list. + ## In other words, this macro prepends elements to another list. + (list& 1 2 3 (list 4 5 6))")] + #;Nil) + (_lux_case (reverse xs) + (#Cons last init) + (return (list (fold (lambda'' [head tail] + (form$ (list (tag$ ["lux" "Cons"]) + (tuple$ (list head tail))))) + last + init))) + + _ + (fail "Wrong syntax for list&"))) + +(macro:' #export (& tokens) + (#Cons [["lux" "doc"] (#TextM "## Tuple types: + (& Text Int Bool) + + ## The empty tuple, a.k.a. Unit. + (&)")] + #;Nil) + (_lux_case (reverse tokens) + #Nil + (return (list (tag$ ["lux" "UnitT"]))) + + (#Cons last prevs) + (return (list (fold (lambda'' [left right] (form$ (list (tag$ ["lux" "ProdT"]) left right))) + last + prevs))) + )) + +(macro:' #export (| tokens) + (#Cons [["lux" "doc"] (#TextM "## Variant types: + (| Text Int Bool) + + ## The empty tuple, a.k.a. Void. + (|)")] + #;Nil) + (_lux_case (reverse tokens) + #Nil + (return (list (tag$ ["lux" "VoidT"]))) + + (#Cons last prevs) + (return (list (fold (lambda'' [left right] (form$ (list (tag$ ["lux" "SumT"]) left right))) + last + prevs))) + )) + +(macro:' (lambda' tokens) + (let'' [name tokens'] (_lux_case tokens + (#Cons [[_ (#SymbolS ["" name])] tokens']) + [name tokens'] + + _ + ["" tokens]) + (_lux_case tokens' + (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) + (_lux_case args + #Nil + (fail "lambda' requires a non-empty arguments tuple.") + + (#Cons [harg targs]) + (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ ["" name]) + harg + (fold (lambda'' [arg body'] + (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ ["" ""]) + arg + body'))) + body + (reverse targs))))))) + + _ + (fail "Wrong syntax for lambda'")))) + +(macro:' (def:''' tokens) + (_lux_case tokens + (#Cons [[_ (#TagS ["" "export"])] + (#Cons [[_ (#FormS (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + (form$ (list (symbol$ ["lux" "lambda'"]) + name + (tuple$ args) + body)))) + (with-export-meta meta))))) + + (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + body)) + (with-export-meta meta))))) + + (#Cons [[_ (#FormS (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + (form$ (list (symbol$ ["lux" "lambda'"]) + name + (tuple$ args) + body)))) + meta)))) + + (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) type body)) + meta)))) + + _ + (fail "Wrong syntax for def'''") + )) + +(def:''' (as-pairs xs) + #Nil + (All [a] (-> ($' List a) ($' List (& a a)))) + (_lux_case xs + (#Cons x (#Cons y xs')) + (#Cons [x y] (as-pairs xs')) + + _ + #Nil)) + +(macro:' (let' tokens) + (_lux_case tokens + (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) + (return (list (fold (_lux_: (-> (& AST AST) AST + AST) + (lambda' [binding body] + (_lux_case binding + [label value] + (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) + body + (reverse (as-pairs bindings))))) + + _ + (fail "Wrong syntax for let'"))) + +(def:''' (any? p xs) + #Nil + (All [a] + (-> (-> a Bool) ($' List a) Bool)) + (_lux_case xs + #Nil + false + + (#Cons x xs') + (_lux_case (p x) + true true + false (any? p xs')))) + +(def:''' (spliced? token) + #Nil + (-> AST Bool) + (_lux_case token + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))] + true + + _ + false)) + +(def:''' (wrap-meta content) + #Nil + (-> AST AST) + (tuple$ (list (tuple$ (list (text$ "") (int$ -1) (int$ -1))) + content))) + +(def:''' (untemplate-list tokens) + #Nil + (-> ($' List AST) AST) + (_lux_case tokens + #Nil + (_meta (#TagS ["lux" "Nil"])) + + (#Cons [token tokens']) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) token (untemplate-list tokens')))))) + +(def:''' (List/append xs ys) + #Nil + (All [a] (-> ($' List a) ($' List a) ($' List a))) + (_lux_case xs + (#Cons x xs') + (#Cons x (List/append xs' ys)) + + #Nil + ys)) + +(def:''' #export (splice-helper xs ys) + (#Cons [["lux" "hidden?"] (#BoolM true)] + #;Nil) + (-> ($' List AST) ($' List AST) ($' List AST)) + (_lux_case xs + (#Cons x xs') + (#Cons x (splice-helper xs' ys)) + + #Nil + ys)) + +(macro:' #export (_$ tokens) + (#Cons [["lux" "doc"] (#TextM "## Left-association for the application of binary functions over variadic arguments. + (_$ Text/append \"Hello, \" name \".\\nHow are you?\") + + ## => + (Text/append (Text/append \"Hello, \" name) \".\\nHow are you?\")")] + #;Nil) + (_lux_case tokens + (#Cons op tokens') + (_lux_case tokens' + (#Cons first nexts) + (return (list (fold (lambda' [a1 a2] (form$ (list op a1 a2))) + first + nexts))) + + _ + (fail "Wrong syntax for _$")) + + _ + (fail "Wrong syntax for _$"))) + +(macro:' #export ($_ tokens) + (#Cons [["lux" "doc"] (#TextM "## Right-association for the application of binary functions over variadic arguments. + ($_ Text/append \"Hello, \" name \".\\nHow are you?\") + + ## => + (Text/append \"Hello, \" (Text/append name \".\\nHow are you?\"))")] + #;Nil) + (_lux_case tokens + (#Cons op tokens') + (_lux_case (reverse tokens') + (#Cons last prevs) + (return (list (fold (lambda' [a1 a2] (form$ (list op a1 a2))) + last + prevs))) + + _ + (fail "Wrong syntax for $_")) + + _ + (fail "Wrong syntax for $_"))) + +## (sig: (Monad m) +## (: (All [a] (-> a (m a))) +## wrap) +## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) +## bind)) +(def:''' Monad + (list& [["lux" "tags"] (#ListM (list (#TextM "wrap") (#TextM "bind")))] + default-def-meta-unexported) + Type + (#NamedT ["lux" "Monad"] + (All [m] + (& (All [a] (-> a ($' m a))) + (All [a b] (-> (-> a ($' m b)) + ($' m a) + ($' m b))))))) + +(def:''' Monad + #Nil + ($' Monad Maybe) + {#wrap + (lambda' return [x] + (#Some x)) + + #bind + (lambda' [f ma] + (_lux_case ma + #None #None + (#Some a) (f a)))}) + +(def:''' Monad + #Nil + ($' Monad Lux) + {#wrap + (lambda' [x] + (lambda' [state] + (#Right state x))) + + #bind + (lambda' [f ma] + (lambda' [state] + (_lux_case (ma state) + (#Left msg) + (#Left msg) + + (#Right state' a) + (f a state'))))}) + +(macro:' (do tokens) + (_lux_case tokens + (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) + (let' [g!wrap (symbol$ ["" "wrap"]) + g!bind (symbol$ ["" " bind "]) + body' (fold (_lux_: (-> (& AST AST) AST AST) + (lambda' [binding body'] + (let' [[var value] binding] + (_lux_case var + [_ (#TagS "" "let")] + (form$ (list (symbol$ ["lux" "let'"]) value body')) + + _ + (form$ (list g!bind + (form$ (list (symbol$ ["" "_lux_lambda"]) (symbol$ ["" ""]) var body')) + value)))))) + body + (reverse (as-pairs bindings)))] + (return (list (form$ (list (symbol$ ["" "_lux_case"]) + monad + (record$ (list [(tag$ ["lux" "wrap"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) + body'))))) + + _ + (fail "Wrong syntax for do"))) + +(def:''' (mapM m f xs) + #Nil + ## (All [m a b] + ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) + (All [m a b] + (-> ($' Monad m) + (-> a ($' m b)) + ($' List a) + ($' m ($' List b)))) + (let' [{#;wrap wrap #;bind _} m] + (_lux_case xs + #Nil + (wrap #Nil) + + (#Cons x xs') + (do m + [y (f x) + ys (mapM m f xs')] + (wrap (#Cons y ys))) + ))) + +(macro:' #export (if tokens) + (list [["lux" "doc"] (#TextM "(if true + \"Oh, yeah!\" + \"Aw hell naw!\")")]) + (_lux_case tokens + (#Cons test (#Cons then (#Cons else #Nil))) + (return (list (form$ (list (symbol$ ["" "_lux_case"]) test + (bool$ true) then + (bool$ false) else)))) + + _ + (fail "Wrong syntax for if"))) + +(def:''' (get k plist) + #Nil + (All [a] + (-> Text ($' List (& Text a)) ($' Maybe a))) + (_lux_case plist + (#Cons [[k' v] plist']) + (if (Text/= k k') + (#Some v) + (get k plist')) + + #Nil + #None)) + +(def:''' (put k v dict) + #Nil + (All [a] + (-> Text a ($' List (& Text a)) ($' List (& Text a)))) + (_lux_case dict + #Nil + (list [k v]) + + (#Cons [[k' v'] dict']) + (if (Text/= k k') + (#Cons [[k' v] dict']) + (#Cons [[k' v'] (put k v dict')])))) + +(def:''' (Text/append x y) + #Nil + (-> Text Text Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [x y])) + +(def:''' (Ident->Text ident) + #Nil + (-> Ident Text) + (let' [[module name] ident] + (_lux_case module + "" name + _ ($_ Text/append module ";" name)))) + +(def:''' (get-meta tag def-meta) + #Nil + (-> Ident Anns ($' Maybe Ann-Value)) + (let' [[prefix name] tag] + (_lux_case def-meta + (#Cons [[prefix' name'] value] def-meta') + (_lux_case [(Text/= prefix prefix') + (Text/= name name')] + [true true] + (#Some value) + + _ + (get-meta tag def-meta')) + + #Nil + #None))) + +(def:''' (resolve-global-symbol ident state) + #Nil + (-> Ident ($' Lux Ident)) + (let' [[module name] ident + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} state] + (_lux_case (get module modules) + (#Some {#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _}) + (_lux_case (get name defs) + (#Some [def-type def-meta def-value]) + (_lux_case (get-meta ["lux" "alias"] def-meta) + (#Some (#IdentM real-name)) + (#Right [state real-name]) + + _ + (#Right [state ident])) + + #None + (#Left ($_ Text/append "Unknown definition: " (Ident->Text ident)))) + + #None + (#Left ($_ Text/append "Unknown module: " module " @ " (Ident->Text ident)))))) + +(def:''' (splice replace? untemplate tag elems) + #Nil + (-> Bool (-> AST ($' Lux AST)) AST ($' List AST) ($' Lux AST)) + (_lux_case replace? + true + (_lux_case (any? spliced? elems) + true + (do Monad + [elems' (_lux_: ($' Lux ($' List AST)) + (mapM Monad + (_lux_: (-> AST ($' Lux AST)) + (lambda' [elem] + (_lux_case elem + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] + (wrap spliced) + + _ + (do Monad + [=elem (untemplate elem)] + (wrap (form$ (list (symbol$ ["" "_lux_:"]) + (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "AST"]))))) + (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list =elem (tag$ ["lux" "Nil"])))))))))))) + elems))] + (wrap (wrap-meta (form$ (list tag + (form$ (list& (symbol$ ["lux" "$_"]) + (symbol$ ["lux" "splice-helper"]) + elems'))))))) + + false + (do Monad + [=elems (mapM Monad untemplate elems)] + (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))) + false + (do Monad + [=elems (mapM Monad untemplate elems)] + (wrap (wrap-meta (form$ (list tag (untemplate-list =elems)))))))) + +(def:''' (untemplate replace? subst token) + #Nil + (-> Bool Text AST ($' Lux AST)) + (_lux_case [replace? token] + [_ [_ (#BoolS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (bool$ value))))) + + [_ [_ (#NatS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "NatS"]) (nat$ value))))) + + [_ [_ (#IntS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (int$ value))))) + + [_ [_ (#FracS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "FracS"]) (frac$ value))))) + + [_ [_ (#RealS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (real$ value))))) + + [_ [_ (#CharS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (char$ value))))) + + [_ [_ (#TextS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (text$ value))))) + + [false [_ (#TagS [module name])]] + (return (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module) (text$ name))))))) + + [true [_ (#TagS [module name])]] + (let' [module' (_lux_case module + "" + subst + + _ + module)] + (return (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name)))))))) + + [true [_ (#SymbolS [module name])]] + (do Monad + [real-name (_lux_case module + "" + (if (Text/= "" subst) + (wrap [module name]) + (resolve-global-symbol [subst name])) + + _ + (wrap [module name])) + #let [[module name] real-name]] + (return (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module) (text$ name)))))))) + + [false [_ (#SymbolS [module name])]] + (return (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module) (text$ name))))))) + + [_ [_ (#TupleS elems)]] + (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) + + [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] + (return unquoted) + + [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~'"])] (#Cons [keep-quoted #Nil])]))]] + (untemplate false subst keep-quoted) + + [_ [meta (#FormS elems)]] + (do Monad + [output (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) + #let [[_ form'] output]] + (return [meta form'])) + + [_ [_ (#RecordS fields)]] + (do Monad + [=fields (mapM Monad + (_lux_: (-> (& AST AST) ($' Lux AST)) + (lambda' [kv] + (let' [[k v] kv] + (do Monad + [=k (untemplate replace? subst k) + =v (untemplate replace? subst v)] + (wrap (tuple$ (list =k =v))))))) + fields)] + (wrap (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) (untemplate-list =fields)))))) + )) + +(macro:' #export (host tokens) + (list [["lux" "doc"] (#TextM "## Macro to treat host-types as Lux-types. + (host java.lang.Object) + + (host java.util.List [java.lang.Long])")]) + (_lux_case tokens + (#Cons [_ (#SymbolS "" class-name)] #Nil) + (return (list (form$ (list (tag$ ["lux" "HostT"]) (text$ class-name) (tag$ ["lux" "Nil"]))))) + + (#Cons [_ (#SymbolS "" class-name)] (#Cons [_ (#TupleS params)] #Nil)) + (return (list (form$ (list (tag$ ["lux" "HostT"]) (text$ class-name) (untemplate-list params))))) + + _ + (fail "Wrong syntax for host"))) + +(def:'' (current-module-name state) + #Nil + ($' Lux Text) + (_lux_case state + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} + (_lux_case (reverse scopes) + (#Cons {#name (#;Cons module-name #Nil) #inner-closures _ #locals _ #closure _} _) + (#Right [state module-name]) + + _ + (#Left "Can't get the module name without a module!") + ))) + +(macro:' #export (` tokens) + (list [["lux" "doc"] (#TextM "## Hygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~@) must also be used as forms. + ## All unprefixed macros will receive their parent module's prefix if imported; otherwise will receive the prefix of the module on which the quasi-quote is being used. + (` (def: (~ name) + (lambda [(~@ args)] + (~ body))))")]) + (_lux_case tokens + (#Cons template #Nil) + (do Monad + [current-module current-module-name + =template (untemplate true current-module template)] + (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) + + _ + (fail "Wrong syntax for `"))) + +(macro:' #export (`' tokens) + (list [["lux" "doc"] (#TextM "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~@) must also be used as forms. + (`' (def: (~ name) + (lambda [(~@ args)] + (~ body))))")]) + (_lux_case tokens + (#Cons template #Nil) + (do Monad + [=template (untemplate true "" template)] + (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) + + _ + (fail "Wrong syntax for `"))) + +(macro:' #export (' tokens) + (list [["lux" "doc"] (#TextM "## Quotation as a macro. + (' \"YOLO\")")]) + (_lux_case tokens + (#Cons template #Nil) + (do Monad + [=template (untemplate false "" template)] + (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) + + _ + (fail "Wrong syntax for '"))) + +(macro:' #export (|> tokens) + (list [["lux" "doc"] (#TextM "## Piping macro. + (|> elems (map ->Text) (interpose \" \") (fold Text/append \"\")) + + ## => + (fold Text/append \"\" + (interpose \" \" + (map ->Text elems)))")]) + (_lux_case tokens + (#Cons [init apps]) + (return (list (fold (_lux_: (-> AST AST AST) + (lambda' [app acc] + (_lux_case app + [_ (#TupleS parts)] + (tuple$ (List/append parts (list acc))) + + [_ (#FormS parts)] + (form$ (List/append parts (list acc))) + + _ + (` ((~ app) (~ acc)))))) + init + apps))) + + _ + (fail "Wrong syntax for |>"))) + +(macro:' #export (<| tokens) + (list [["lux" "doc"] (#TextM "## Reverse piping macro. + (<| (fold Text/append \"\") (interpose \" \") (map ->Text) elems) + + ## => + (fold Text/append \"\" + (interpose \" \" + (map ->Text elems)))")]) + (_lux_case (reverse tokens) + (#Cons [init apps]) + (return (list (fold (_lux_: (-> AST AST AST) + (lambda' [app acc] + (_lux_case app + [_ (#TupleS parts)] + (tuple$ (List/append parts (list acc))) + + [_ (#FormS parts)] + (form$ (List/append parts (list acc))) + + _ + (` ((~ app) (~ acc)))))) + init + apps))) + + _ + (fail "Wrong syntax for <|"))) + +(def:''' #export (. f g) + (list [["lux" "doc"] (#TextM "Function composition.")]) + (All [a b c] + (-> (-> b c) (-> a b) (-> a c))) + (lambda' [x] (f (g x)))) + +(def:''' (get-ident x) + #Nil + (-> AST ($' Maybe Ident)) + (_lux_case x + [_ (#SymbolS sname)] + (#Some sname) + + _ + #None)) + +(def:''' (get-tag x) + #Nil + (-> AST ($' Maybe Ident)) + (_lux_case x + [_ (#TagS sname)] + (#Some sname) + + _ + #None)) + +(def:''' (get-name x) + #Nil + (-> AST ($' Maybe Text)) + (_lux_case x + [_ (#SymbolS "" sname)] + (#Some sname) + + _ + #None)) + +(def:''' (tuple->list tuple) + #Nil + (-> AST ($' Maybe ($' List AST))) + (_lux_case tuple + [_ (#TupleS members)] + (#Some members) + + _ + #None)) + +(def:''' (apply-template env template) + #Nil + (-> RepEnv AST AST) + (_lux_case template + [_ (#SymbolS "" sname)] + (_lux_case (get-rep sname env) + (#Some subst) + subst + + _ + template) + + [meta (#TupleS elems)] + [meta (#TupleS (map (apply-template env) elems))] + + [meta (#FormS elems)] + [meta (#FormS (map (apply-template env) elems))] + + [meta (#RecordS members)] + [meta (#RecordS (map (_lux_: (-> (& AST AST) (& AST AST)) + (lambda' [kv] + (let' [[slot value] kv] + [(apply-template env slot) (apply-template env value)]))) + members))] + + _ + template)) + +(def:''' (join-map f xs) + #Nil + (All [a b] + (-> (-> a ($' List b)) ($' List a) ($' List b))) + (_lux_case xs + #Nil + #Nil + + (#Cons [x xs']) + (List/append (f x) (join-map f xs')))) + +(def:''' (every? p xs) + #Nil + (All [a] + (-> (-> a Bool) ($' List a) Bool)) + (fold (lambda' [_2 _1] (if _1 (p _2) false)) true xs)) + +(def:''' (i= x y) + #Nil + (-> Int Int Bool) + (_lux_proc ["jvm" "leq"] [x y])) + +(def:''' (n= x y) + #Nil + (-> Nat Nat Bool) + (_lux_proc ["nat" "="] [x y])) + +(def:''' (->Text x) + #Nil + (-> (host java.lang.Object) Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x])) + +(macro:' #export (do-template tokens) + (list [["lux" "doc"] (#TextM "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary. + (do-template [ ] + [(def: #export + (-> Int Int) + (+ ))] + + [inc 1] + [dec -1])")]) + (_lux_case tokens + (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) + (_lux_case [(mapM Monad get-name bindings) + (mapM Monad tuple->list data)] + [(#Some bindings') (#Some data')] + (let' [apply (_lux_: (-> RepEnv ($' List AST)) + (lambda' [env] (map (apply-template env) templates))) + num-bindings (length bindings')] + (if (every? (i= num-bindings) (map length data')) + (|> data' + (join-map (. apply (make-env bindings'))) + return) + (fail (Text/append "Irregular arguments vectors for do-template. Expected size " (->Text num-bindings))))) + + _ + (fail "Wrong syntax for do-template")) + + _ + (fail "Wrong syntax for do-template"))) + + +(do-template [ ] + [(def:''' ( x y) + #Nil + (-> Bool) + (_lux_proc ["jvm" ] [x y]))] + + ## [i= "leq" Int] + [i> "lgt" Int] + [i< "llt" Int] + ) + +(do-template [ ] + [(def:''' ( x y) + #Nil + (-> Bool) + (if ( x y) + true + ( x y)))] + + [i>= i> i= Int] + [i<= i< i= Int] + ) + +(do-template [ ] + [(def:''' ( x y) + #Nil + (-> ) + (_lux_proc [x y]))] + + [i+ ["jvm" "ladd"] Int] + [i- ["jvm" "lsub"] Int] + [i* ["jvm" "lmul"] Int] + [i/ ["jvm" "ldiv"] Int] + [i% ["jvm" "lrem"] Int] + + [n+ ["nat" "+"] Nat] + [n- ["nat" "-"] Nat] + [n* ["nat" "*"] Nat] + [n/ ["nat" "/"] Nat] + [n% ["nat" "%"] Nat] + ) + +(def:''' (multiple? div n) + #Nil + (-> Int Int Bool) + (i= 0 (i% n div))) + +(def:''' #export (not x) + #Nil + (-> Bool Bool) + (if x false true)) + +(def:''' (find-macro' modules current-module module name) + #Nil + (-> ($' List (& Text Module)) + Text Text Text + ($' Maybe Macro)) + (do Monad + [$module (get module modules) + gdef (let' [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _} (_lux_: Module $module)] + (get name bindings))] + (let' [[def-type def-meta def-value] (_lux_: Def gdef)] + (_lux_case (get-meta ["lux" "macro?"] def-meta) + (#Some (#BoolM true)) + (_lux_case (get-meta ["lux" "export?"] def-meta) + (#Some (#BoolM true)) + (#Some (_lux_:! Macro def-value)) + + _ + (if (Text/= module current-module) + (#Some (_lux_:! Macro def-value)) + #None)) + + _ + (_lux_case (get-meta ["lux" "alias"] def-meta) + (#Some (#IdentM [r-module r-name])) + (find-macro' modules current-module r-module r-name) + + _ + #None) + )) + )) + +(def:''' (normalize ident) + #Nil + (-> Ident ($' Lux Ident)) + (_lux_case ident + ["" name] + (do Monad + [module-name current-module-name] + (wrap [module-name name])) + + _ + (return ident))) + +(def:''' (find-macro ident) + #Nil + (-> Ident ($' Lux ($' Maybe Macro))) + (do Monad + [current-module current-module-name] + (let' [[module name] ident] + (lambda' [state] + (_lux_case state + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected + #cursor cursor + #scope-type-vars scope-type-vars} + (#Right state (find-macro' modules current-module module name))))))) + +(def:''' (macro? ident) + #Nil + (-> Ident ($' Lux Bool)) + (do Monad + [ident (normalize ident) + output (find-macro ident)] + (wrap (_lux_case output + (#Some _) true + #None false)))) + +(def:''' (List/join xs) + #Nil + (All [a] + (-> ($' List ($' List a)) ($' List a))) + (fold List/append #Nil (reverse xs))) + +(def:''' (interpose sep xs) + #Nil + (All [a] + (-> a ($' List a) ($' List a))) + (_lux_case xs + #Nil + xs + + (#Cons [x #Nil]) + xs + + (#Cons [x xs']) + (list& x sep (interpose sep xs')))) + +(def:''' (macro-expand-once token) + #Nil + (-> AST ($' Lux ($' List AST))) + (_lux_case token + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] + (do Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (macro args) + + #None + (return (list token)))) + + _ + (return (list token)))) + +(def:''' (macro-expand token) + #Nil + (-> AST ($' Lux ($' List AST))) + (_lux_case token + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] + (do Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (do Monad + [expansion (macro args) + expansion' (mapM Monad macro-expand expansion)] + (wrap (List/join expansion'))) + + #None + (return (list token)))) + + _ + (return (list token)))) + +(def:''' (macro-expand-all syntax) + #Nil + (-> AST ($' Lux ($' List AST))) + (_lux_case syntax + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] + (do Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (do Monad + [expansion (macro args) + expansion' (mapM Monad macro-expand-all expansion)] + (wrap (List/join expansion'))) + + #None + (do Monad + [args' (mapM Monad macro-expand-all args)] + (wrap (list (form$ (#Cons (symbol$ macro-name) (List/join args')))))))) + + [_ (#FormS members)] + (do Monad + [members' (mapM Monad macro-expand-all members)] + (wrap (list (form$ (List/join members'))))) + + [_ (#TupleS members)] + (do Monad + [members' (mapM Monad macro-expand-all members)] + (wrap (list (tuple$ (List/join members'))))) + + [_ (#RecordS pairs)] + (do Monad + [pairs' (mapM Monad + (lambda' [kv] + (let' [[key val] kv] + (do Monad + [val' (macro-expand-all val)] + (_lux_case val' + (#;Cons val'' #;Nil) + (return [key val'']) + + _ + (fail "The value-part of a KV-pair in a record must macro-expand to a single AST."))))) + pairs)] + (wrap (list (record$ pairs')))) + + _ + (return (list syntax)))) + +(def:''' (walk-type type) + #Nil + (-> AST AST) + (_lux_case type + [_ (#FormS (#Cons [_ (#TagS tag)] parts))] + (form$ (#Cons [(tag$ tag) (map walk-type parts)])) + + [_ (#TupleS members)] + (` (& (~@ (map walk-type members)))) + + [_ (#FormS (#Cons type-fn args))] + (fold (_lux_: (-> AST AST AST) + (lambda' [arg type-fn] (` (#;AppT (~ type-fn) (~ arg))))) + (walk-type type-fn) + (map walk-type args)) + + _ + type)) + +(macro:' #export (type tokens) + (list [["lux" "doc"] (#TextM "## Takes a type expression and returns it's representation as data-structure. + (type (All [a] (Maybe (List a))))")]) + (_lux_case tokens + (#Cons type #Nil) + (do Monad + [type+ (macro-expand-all type)] + (_lux_case type+ + (#Cons type' #Nil) + (wrap (list (walk-type type'))) + + _ + (fail "The expansion of the type-syntax had to yield a single element."))) + + _ + (fail "Wrong syntax for type"))) + +(macro:' #export (: tokens) + (list [["lux" "doc"] (#TextM "## The type-annotation macro. + (: (List Int) (list 1 2 3))")]) + (_lux_case tokens + (#Cons type (#Cons value #Nil)) + (return (list (` (;_lux_: (type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :"))) + +(macro:' #export (:! tokens) + (list [["lux" "doc"] (#TextM "## The type-coercion macro. + (:! Dinosaur (list 1 2 3))")]) + (_lux_case tokens + (#Cons type (#Cons value #Nil)) + (return (list (` (;_lux_:! (type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :!"))) + +(def:''' (empty? xs) + #Nil + (All [a] (-> ($' List a) Bool)) + (_lux_case xs + #Nil true + _ false)) + +(do-template [ ] + [(def:''' ( xy) + #Nil + (All [a b] (-> (& a b) )) + (let' [[x y] xy] ))] + + [first a x] + [second b y]) + +(def:''' (unfold-type-def type-asts) + #Nil + (-> ($' List AST) ($' Lux (& AST ($' Maybe ($' List Text))))) + (_lux_case type-asts + (#Cons [_ (#RecordS pairs)] #;Nil) + (do Monad + [members (mapM Monad + (: (-> [AST AST] (Lux [Text AST])) + (lambda' [pair] + (_lux_case pair + [[_ (#TagS "" member-name)] member-type] + (return [member-name member-type]) + + _ + (fail "Wrong syntax for variant case.")))) + pairs)] + (return [(` (& (~@ (map second members)))) + (#Some (map first members))])) + + (#Cons type #Nil) + (_lux_case type + [_ (#TagS "" member-name)] + (return [(` #;UnitT) (#;Some (list member-name))]) + + [_ (#FormS (#Cons [_ (#TagS "" member-name)] member-types))] + (return [(` (& (~@ member-types))) (#;Some (list member-name))]) + + _ + (return [type #None])) + + (#Cons case cases) + (do Monad + [members (mapM Monad + (: (-> AST (Lux [Text AST])) + (lambda' [case] + (_lux_case case + [_ (#TagS "" member-name)] + (return [member-name (` Unit)]) + + [_ (#FormS (#Cons [_ (#TagS "" member-name)] (#Cons member-type #Nil)))] + (return [member-name member-type]) + + [_ (#FormS (#Cons [_ (#TagS "" member-name)] member-types))] + (return [member-name (` (& (~@ member-types)))]) + + _ + (fail "Wrong syntax for variant case.")))) + (list& case cases))] + (return [(` (| (~@ (map second members)))) + (#Some (map first members))])) + + _ + (fail "Improper type-definition syntax"))) + +(def:''' (gensym prefix state) + #Nil + (-> Text ($' Lux AST)) + (_lux_case state + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected + #cursor cursor + #scope-type-vars scope-type-vars} + (#Right {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed (n+ +1 seed) #expected expected + #cursor cursor + #scope-type-vars scope-type-vars} + (symbol$ ["" ($_ Text/append "__gensym__" prefix (->Text seed))])))) + +(macro:' #export (Rec tokens) + (list [["lux" "doc"] (#TextM "## Parameter-less recursive types. + ## A name has to be given to the whole type, to use it within it's body. + (Rec Self + [Int (List Self)])")]) + (_lux_case tokens + (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil)) + (let' [body' (replace-syntax (list [name (` (#AppT (~ (make-bound +0)) (~ (make-bound +1))))]) body)] + (return (list (` (#AppT (#UnivQ #Nil (~ body')) Void))))) + + _ + (fail "Wrong syntax for Rec"))) + +(macro:' #export (exec tokens) + (list [["lux" "doc"] (#TextM "## Sequential execution of expressions (great for side-effects). + (exec + (log! \"#1\") + (log! \"#2\") + (log! \"#3\") + \"YOLO\")")]) + (_lux_case (reverse tokens) + (#Cons value actions) + (let' [dummy (symbol$ ["" ""])] + (return (list (fold (_lux_: (-> AST AST AST) + (lambda' [pre post] (` (;_lux_case (~ pre) (~ dummy) (~ post))))) + value + actions)))) + + _ + (fail "Wrong syntax for exec"))) + +(macro:' (def:' tokens) + (let' [[export? tokens'] (_lux_case tokens + (#Cons [_ (#TagS "" "export")] tokens') + [true tokens'] + + _ + [false tokens]) + parts (: (Maybe [AST (List AST) (Maybe AST) AST]) + (_lux_case tokens' + (#Cons [_ (#FormS (#Cons name args))] (#Cons type (#Cons body #Nil))) + (#Some name args (#Some type) body) + + (#Cons name (#Cons type (#Cons body #Nil))) + (#Some name #Nil (#Some type) body) + + (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil)) + (#Some name args #None body) + + (#Cons name (#Cons body #Nil)) + (#Some name #Nil #None body) + + _ + #None))] + (_lux_case parts + (#Some name args ?type body) + (let' [body' (_lux_case args + #Nil + body + + _ + (` (lambda' (~ name) [(~@ args)] (~ body)))) + body'' (_lux_case ?type + (#Some type) + (` (: (~ type) (~ body'))) + + #None + body')] + (return (list (` (;_lux_def (~ name) (~ body'') + (~ (if export? + (with-export-meta (tag$ ["lux" "Nil"])) + (tag$ ["lux" "Nil"])))))))) + + #None + (fail "Wrong syntax for def'")))) + +(def:' (rejoin-pair pair) + (-> [AST AST] (List AST)) + (let' [[left right] pair] + (list left right))) + +(def:''' (Nat->Text x) + #Nil + (-> Nat Text) + (_lux_proc ["nat" "encode"] [x])) + +(def:''' (Frac->Text x) + #Nil + (-> Frac Text) + (_lux_proc ["frac" "encode"] [x])) + +(def:' (ast-to-text ast) + (-> AST Text) + (_lux_case ast + [_ (#BoolS value)] + (->Text value) + + [_ (#NatS value)] + (Nat->Text value) + + [_ (#IntS value)] + (->Text value) + + [_ (#FracS value)] + (Frac->Text value) + + [_ (#RealS value)] + (->Text value) + + [_ (#CharS value)] + ($_ Text/append "#" "\"" (->Text value) "\"") + + [_ (#TextS value)] + ($_ Text/append "\"" value "\"") + + [_ (#SymbolS [prefix name])] + (if (Text/= "" prefix) + name + ($_ Text/append prefix ";" name)) + + [_ (#TagS [prefix name])] + (if (Text/= "" prefix) + ($_ Text/append "#" name) + ($_ Text/append "#" prefix ";" name)) + + [_ (#FormS xs)] + ($_ Text/append "(" (|> xs + (map ast-to-text) + (interpose " ") + reverse + (fold Text/append "")) ")") + + [_ (#TupleS xs)] + ($_ Text/append "[" (|> xs + (map ast-to-text) + (interpose " ") + reverse + (fold Text/append "")) "]") + + [_ (#RecordS kvs)] + ($_ Text/append "{" (|> kvs + (map (lambda' [kv] (_lux_case kv [k v] ($_ Text/append (ast-to-text k) " " (ast-to-text v))))) + (interpose " ") + reverse + (fold Text/append "")) "}") + )) + +(def:' (expander branches) + (-> (List AST) (Lux (List AST))) + (_lux_case branches + (#;Cons [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] + (#;Cons body + branches')) + (do Monad + [??? (macro? macro-name)] + (if ??? + (do Monad + [init-expansion (macro-expand-once (form$ (list& (symbol$ macro-name) (form$ macro-args) body branches')))] + (expander init-expansion)) + (do Monad + [sub-expansion (expander branches')] + (wrap (list& (form$ (list& (symbol$ macro-name) macro-args)) + body + sub-expansion))))) + + (#;Cons pattern (#;Cons body branches')) + (do Monad + [sub-expansion (expander branches')] + (wrap (list& pattern body sub-expansion))) + + #;Nil + (do Monad [] (wrap (list))) + + _ + (fail ($_ Text/append "\"lux;case\" expects an even number of tokens: " (|> branches + (map ast-to-text) + (interpose " ") + reverse + (fold Text/append "")))))) + +(macro:' #export (case tokens) + (list [["lux" "doc"] (#TextM "## The pattern-matching macro. + ## Allows the usage of macros within the patterns to provide custom syntax. + (case (: (List Int) (list 1 2 3)) + (#Cons x (#Cons y (#Cons z #Nil))) + (#Some ($_ * x y z)) + + _ + #None)")]) + (_lux_case tokens + (#Cons value branches) + (do Monad + [expansion (expander branches)] + (wrap (list (` (;_lux_case (~ value) (~@ expansion)))))) + + _ + (fail "Wrong syntax for case"))) + +(macro:' #export (^ tokens) + (list [["lux" "doc"] (#TextM "## Macro-expanding patterns. + ## It's a special macro meant to be used with case. + (case (: (List Int) (list 1 2 3)) + (^ (list x y z)) + (#Some ($_ * x y z)) + + _ + #None)")]) + (case tokens + (#Cons [_ (#FormS (#Cons pattern #Nil))] (#Cons body branches)) + (do Monad + [pattern+ (macro-expand-all pattern)] + (case pattern+ + (#Cons pattern' #Nil) + (wrap (list& pattern' body branches)) + + _ + (fail "^ can only expand to 1 pattern."))) + + _ + (fail "Wrong syntax for ^ macro"))) + +(macro:' #export (^or tokens) + (list [["lux" "doc"] (#TextM "## Or-patterns. + ## It's a special macro meant to be used with case. + (type: Weekday + (| #Monday + #Tuesday + #Wednesday + #Thursday + #Friday + #Saturday + #Sunday)) + + (def: (weekend? day) + (-> Weekday Bool) + (case day + (^or #Saturday #Sunday) + true + + _ + false))")]) + (case tokens + (^ (list& [_ (#FormS patterns)] body branches)) + (case patterns + #Nil + (fail "^or can't have 0 patterns") + + _ + (let' [pairs (|> patterns + (map (lambda' [pattern] (list pattern body))) + (List/join))] + (return (List/append pairs branches)))) + _ + (fail "Wrong syntax for ^or"))) + +(def:' (symbol? ast) + (-> AST Bool) + (case ast + [_ (#SymbolS _)] + true + + _ + false)) + +(macro:' #export (let tokens) + (list [["lux" "doc"] (#TextM "## Creates local bindings. + ## Can (optionally) use pattern-matching macros when binding. + (let [x (foo bar) + y (baz quux)] + (op x y))")]) + (case tokens + (^ (list [_ (#TupleS bindings)] body)) + (if (multiple? 2 (length bindings)) + (|> bindings as-pairs reverse + (fold (: (-> [AST AST] AST AST) + (lambda' [lr body'] + (let' [[l r] lr] + (if (symbol? l) + (` (;_lux_case (~ r) (~ l) (~ body'))) + (` (case (~ r) (~ l) (~ body'))))))) + body) + list + return) + (fail "let requires an even number of parts")) + + _ + (fail "Wrong syntax for let"))) + +(macro:' #export (lambda tokens) + (list [["lux" "doc"] (#TextM "## Syntax for creating functions. + ## Allows for giving the function itself a name, for the sake of recursion. + (: (All [a b] (-> a b a)) + (lambda [x y] x)) + + (: (All [a b] (-> a b a)) + (lambda const [x y] x))")]) + (case (: (Maybe [Ident AST (List AST) AST]) + (case tokens + (^ (list [_ (#TupleS (#Cons head tail))] body)) + (#Some ["" ""] head tail body) + + (^ (list [_ (#SymbolS ["" name])] [_ (#TupleS (#Cons head tail))] body)) + (#Some ["" name] head tail body) + + _ + #None)) + (#Some ident head tail body) + (let [g!blank (symbol$ ["" ""]) + g!name (symbol$ ident) + body+ (fold (: (-> AST AST AST) + (lambda' [arg body'] + (if (symbol? arg) + (` (;_lux_lambda (~ g!blank) (~ arg) (~ body'))) + (` (;_lux_lambda (~ g!blank) (~ g!blank) + (case (~ g!blank) (~ arg) (~ body'))))))) + body + (reverse tail))] + (return (list (if (symbol? head) + (` (;_lux_lambda (~ g!name) (~ head) (~ body+))) + (` (;_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) + + #None + (fail "Wrong syntax for lambda"))) + +(def:' (process-def-meta-value ast) + (-> AST (Lux AST)) + (case ast + [_ (#BoolS value)] + (return (form$ (list (tag$ ["lux" "BoolM"]) (bool$ value)))) + + [_ (#NatS value)] + (return (form$ (list (tag$ ["lux" "NatM"]) (nat$ value)))) + + [_ (#IntS value)] + (return (form$ (list (tag$ ["lux" "IntM"]) (int$ value)))) + + [_ (#FracS value)] + (return (form$ (list (tag$ ["lux" "FracM"]) (frac$ value)))) + + [_ (#RealS value)] + (return (form$ (list (tag$ ["lux" "RealM"]) (real$ value)))) + + [_ (#CharS value)] + (return (form$ (list (tag$ ["lux" "CharM"]) (char$ value)))) + + [_ (#TextS value)] + (return (form$ (list (tag$ ["lux" "TextM"]) (text$ value)))) + + [_ (#TagS [prefix name])] + (return (form$ (list (tag$ ["lux" "IdentM"]) (tuple$ (list (text$ prefix) (text$ name)))))) + + (^or [_ (#FormS _)] [_ (#SymbolS _)]) + (return ast) + + [_ (#TupleS xs)] + (do Monad + [=xs (mapM Monad process-def-meta-value xs)] + (wrap (form$ (list (tag$ ["lux" "ListM"]) (untemplate-list =xs))))) + + [_ (#RecordS kvs)] + (do Monad + [=xs (mapM Monad + (: (-> [AST AST] (Lux AST)) + (lambda [[k v]] + (case k + [_ (#TextS =k)] + (do Monad + [=v (process-def-meta-value v)] + (wrap (tuple$ (list (text$ =k) =v)))) + + _ + (fail (Text/append "Wrong syntax for DictM key: " (ast-to-text k)))))) + kvs)] + (wrap (form$ (list (tag$ ["lux" "DictM"]) (untemplate-list =xs))))) + )) + +(def:' (process-def-meta ast) + (-> AST (Lux AST)) + (case ast + [_ (#RecordS kvs)] + (do Monad + [=kvs (mapM Monad + (: (-> [AST AST] (Lux AST)) + (lambda [[k v]] + (case k + [_ (#TagS [pk nk])] + (do Monad + [=v (process-def-meta-value v)] + (wrap (tuple$ (list (tuple$ (list (text$ pk) (text$ nk))) + =v)))) + + _ + (fail (Text/append "Wrong syntax for Anns: " (ast-to-text ast)))))) + kvs)] + (wrap (untemplate-list =kvs))) + + _ + (fail (Text/append "Wrong syntax for Anns: " (ast-to-text ast))))) + +(def:' (with-func-args args meta) + (-> (List AST) AST AST) + (case args + #;Nil + meta + + _ + (` (#;Cons [["lux" "func-args"] + (#;ListM (list (~@ (map (lambda [arg] + (` (#;TextM (~ (text$ (ast-to-text arg)))))) + args))))] + (~ meta))))) + +(def:' (with-type-args args) + (-> (List AST) AST) + (` {#;type-args (#;ListM (list (~@ (map (lambda [arg] + (` (#;TextM (~ (text$ (ast-to-text arg)))))) + args))))})) + +(def:' Export-Level + Type + ($' Either + Unit ## Exported + Unit ## Hidden + )) + +(def:' (export-level^ tokens) + (-> (List AST) [(Maybe Export-Level) (List AST)]) + (case tokens + (#Cons [_ (#TagS [_ "export"])] tokens') + [(#;Some (#;Left [])) tokens'] + + (#Cons [_ (#TagS [_ "hidden"])] tokens') + [(#;Some (#;Right [])) tokens'] + + _ + [#;None tokens])) + +(def:' (export-level ?el) + (-> (Maybe Export-Level) (List AST)) + (case ?el + #;None + (list) + + (#;Some (#;Left [])) + (list (' #export)) + + (#;Some (#;Right [])) + (list (' #hidden)))) + +(macro:' #export (def: tokens) + (list [["lux" "doc"] (#TextM "## Defines global constants/functions. + (def: (rejoin-pair pair) + (-> [AST AST] (List AST)) + (let [[left right] pair] + (list left right))) + + (def: branching-exponent + Int + 5)")]) + (let [[export? tokens'] (export-level^ tokens) + parts (: (Maybe [AST (List AST) (Maybe AST) AST AST]) + (case tokens' + (^ (list [_ (#FormS (#Cons name args))] meta type body)) + (#Some name args (#Some type) body meta) + + (^ (list name meta type body)) + (#Some name #Nil (#Some type) body meta) + + (^ (list [_ (#FormS (#Cons name args))] type body)) + (#Some name args (#Some type) body (' {})) + + (^ (list name type body)) + (#Some name #Nil (#Some type) body (' {})) + + (^ (list [_ (#FormS (#Cons name args))] body)) + (#Some name args #None body (' {})) + + (^ (list name body)) + (#Some name #Nil #None body (' {})) + + _ + #None))] + (case parts + (#Some name args ?type body meta) + (let [body (case args + #Nil + body + + _ + (` (lambda (~ name) [(~@ args)] (~ body)))) + body (case ?type + (#Some type) + (` (: (~ type) (~ body))) + + #None + body)] + (do Monad + [=meta (process-def-meta meta)] + (return (list (` (;_lux_def (~ name) (~ body) (~ (with-func-args args + (case export? + #;None + =meta + + (#;Some (#;Left [])) + (with-export-meta =meta) + + (#;Some (#;Right [])) + (|> =meta + with-export-meta + with-hidden-meta) + ))))))))) + + #None + (fail "Wrong syntax for def")))) + +(def: (meta-ast-add addition meta) + (-> [AST AST] AST AST) + (case [addition meta] + [[name value] [cursor (#;RecordS pairs)]] + [cursor (#;RecordS (#;Cons [name value] pairs))] + + _ + meta)) + +(def: (meta-ast-merge addition base) + (-> AST AST AST) + (case addition + [cursor (#;RecordS pairs)] + (fold meta-ast-add base pairs) + + _ + base)) + +(macro:' #export (macro: tokens) + (list [["lux" "doc"] (#TextM "(macro: #export (ident-for tokens) + (case tokens + (^template [] + (^ (list [_ ( [prefix name])])) + (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))) + ([#;SymbolS] [#;TagS]) + + _ + (fail \"Wrong syntax for ident-for\")))")]) + (let [[exported? tokens] (export-level^ tokens) + name+args+meta+body?? (: (Maybe [Ident (List AST) AST AST]) + (case tokens + (^ (list [_ (#;FormS (list& [_ (#SymbolS name)] args))] body)) + (#Some [name args (` {}) body]) + + (^ (list [_ (#;SymbolS name)] body)) + (#Some [name #Nil (` {}) body]) + + (^ (list [_ (#;FormS (list& [_ (#SymbolS name)] args))] [meta-rec-cursor (#;RecordS meta-rec-parts)] body)) + (#Some [name args [meta-rec-cursor (#;RecordS meta-rec-parts)] body]) + + (^ (list [_ (#;SymbolS name)] [meta-rec-cursor (#;RecordS meta-rec-parts)] body)) + (#Some [name #Nil [meta-rec-cursor (#;RecordS meta-rec-parts)] body]) + + _ + #None))] + (case name+args+meta+body?? + (#Some [name args meta body]) + (let [name (symbol$ name) + def-sig (case args + #;Nil name + _ (` ((~ name) (~@ args))))] + (return (list (` (;;def: (~@ (export-level exported?)) + (~ def-sig) + (~ (meta-ast-merge (` {#;macro? true}) + meta)) + + ;;Macro + (~ body)))))) + + + #None + (fail "Wrong syntax for macro:")))) + +(macro: #export (sig: tokens) + {#;doc "## Definition of signatures ala ML. + (sig: #export (Ord a) + (: (Eq a) + eq) + (: (-> a a Bool) + <) + (: (-> a a Bool) + <=) + (: (-> a a Bool) + >) + (: (-> a a Bool) + >=))"} + (let [[exported? tokens'] (export-level^ tokens) + ?parts (: (Maybe [Ident (List AST) AST (List AST)]) + (case tokens' + (^ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs)) + (#Some name args [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs) + + (^ (list& [_ (#SymbolS name)] [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs)) + (#Some name #Nil [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs) + + (^ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] sigs)) + (#Some name args (` {}) sigs) + + (^ (list& [_ (#SymbolS name)] sigs)) + (#Some name #Nil (` {}) sigs) + + _ + #None))] + (case ?parts + (#Some name args meta sigs) + (do Monad + [name+ (normalize name) + sigs' (mapM Monad macro-expand sigs) + members (: (Lux (List [Text AST])) + (mapM Monad + (: (-> AST (Lux [Text AST])) + (lambda [token] + (case token + (^ [_ (#FormS (list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))]) + (wrap [name type]) + + _ + (fail "Signatures require typed members!")))) + (List/join sigs'))) + #let [[_module _name] name+ + def-name (symbol$ name) + sig-type (record$ (map (: (-> [Text AST] [AST AST]) + (lambda [[m-name m-type]] + [(tag$ ["" m-name]) m-type])) + members)) + sig-meta (meta-ast-merge (` {#;sig? true}) + meta) + usage (case args + #;Nil + def-name + + _ + (` ((~ def-name) (~@ args))))]] + (return (list (` (;;type: (~@ (export-level exported?)) (~ usage) (~ sig-meta) (~ sig-type)))))) + + #None + (fail "Wrong syntax for sig:")))) + +(def: (find f xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #Nil + #None + + (#Cons x xs') + (case (f x) + #None + (find f xs') + + (#Some y) + (#Some y)))) + +(def: (last-index-of part text) + (-> Text Text Int) + (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:lastIndexOf:java.lang.String"] [text part])])) + +(def: (index-of part text) + (-> Text Text Int) + (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:indexOf:java.lang.String"] [text part])])) + +(def: (substring1 idx text) + (-> Int Text Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int"] [text (_lux_proc ["jvm" "l2i"] [idx])])) + +(def: (substring2 idx1 idx2 text) + (-> Int Int Text Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] [text (_lux_proc ["jvm" "l2i"] [idx1]) (_lux_proc ["jvm" "l2i"] [idx2])])) + +(def: #export (log! message) + (-> Text Unit) + (_lux_proc ["jvm" "invokevirtual:java.io.PrintStream:println:java.lang.String"] + [(_lux_proc ["jvm" "getstatic:java.lang.System:out"] []) message])) + +(def: (split-text splitter input) + (-> Text Text (List Text)) + (let [idx (index-of splitter input)] + (if (i< idx 0) + (#Cons input #Nil) + (#Cons (substring2 0 idx input) + (split-text splitter (substring1 (i+ 1 idx) input)))))) + +(def: (split-module-contexts module) + (-> Text (List Text)) + (#Cons module (let [idx (last-index-of "/" module)] + (if (i< idx 0) + #Nil + (split-module-contexts (substring2 0 idx module)))))) + +(def: (split-module module) + (-> Text (List Text)) + (let [idx (index-of "/" module)] + (if (i< idx 0) + (list module) + (list& (substring2 0 idx module) (split-module (substring1 (i+ 1 idx) module)))))) + +(def: (at idx xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons x xs') + (if (i= idx 0) + (#Some x) + (at (i- idx 1) xs') + ))) + +(def: (beta-reduce env type) + (-> (List Type) Type Type) + (case type + (#SumT left right) + (#SumT (beta-reduce env left) (beta-reduce env right)) + + (#ProdT left right) + (#ProdT (beta-reduce env left) (beta-reduce env right)) + + (#AppT ?type-fn ?type-arg) + (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) + + (#UnivQ ?local-env ?local-def) + (case ?local-env + #Nil + (#UnivQ env ?local-def) + + _ + type) + + (#ExQ ?local-env ?local-def) + (case ?local-env + #Nil + (#ExQ env ?local-def) + + _ + type) + + (#LambdaT ?input ?output) + (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) + + (#BoundT idx) + (case (at (_lux_proc ["nat" "to-int"] [idx]) env) + (#Some bound) + bound + + _ + type) + + (#NamedT name type) + (beta-reduce env type) + + _ + type + )) + +(def: (apply-type type-fn param) + (-> Type Type (Maybe Type)) + (case type-fn + (#UnivQ env body) + (#Some (beta-reduce (list& type-fn param env) body)) + + (#ExQ env body) + (#Some (beta-reduce (list& type-fn param env) body)) + + (#AppT F A) + (do Monad + [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + (#NamedT name type) + (apply-type type param) + + _ + #None)) + +(do-template [ ] + [(def: ( type) + (-> Type (List Type)) + (case type + ( left right) + (list& left ( right)) + + _ + (list type)))] + + [flatten-sum #;SumT] + [flatten-prod #;ProdT] + [flatten-lambda #;LambdaT] + [flatten-app #;AppT] + ) + +(def: (resolve-struct-type type) + (-> Type (Maybe (List Type))) + (case type + (#ProdT _) + (#Some (flatten-prod type)) + + (#AppT fun arg) + (do Monad + [output (apply-type fun arg)] + (resolve-struct-type output)) + + (#UnivQ _ body) + (resolve-struct-type body) + + (#ExQ _ body) + (resolve-struct-type body) + + (#NamedT name type) + (resolve-struct-type type) + + (#SumT _) + #None + + _ + (#Some (list type)))) + +(def: (find-module name) + (-> Text (Lux Module)) + (lambda [state] + (let [{#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} state] + (case (get name modules) + (#Some module) + (#Right state module) + + _ + (#Left ($_ Text/append "Unknown module: " name)))))) + +(def: get-current-module + (Lux Module) + (do Monad + [module-name current-module-name] + (find-module module-name))) + +(def: (resolve-tag [module name]) + (-> Ident (Lux [Nat (List Ident) Bool Type])) + (do Monad + [=module (find-module module) + #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags-table #types types #module-anns _} =module]] + (case (get name tags-table) + (#Some output) + (return output) + + _ + (fail (Text/append "Unknown tag: " (Ident->Text [module name])))))) + +(def: (resolve-type-tags type) + (-> Type (Lux (Maybe [(List Ident) (List Type)]))) + (case type + (#AppT fun arg) + (resolve-type-tags fun) + + (#UnivQ env body) + (resolve-type-tags body) + + (#ExQ env body) + (resolve-type-tags body) + + (#NamedT [module name] _) + (do Monad + [=module (find-module module) + #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _} =module]] + (case (get name types) + (#Some [tags exported? (#NamedT _ _type)]) + (case (resolve-struct-type _type) + (#Some members) + (return (#Some [tags members])) + + _ + (return #None)) + + _ + (return #None))) + + _ + (return #None))) + +(def: get-expected-type + (Lux Type) + (lambda [state] + (let [{#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} state] + (case expected + (#Some type) + (#Right state type) + + #None + (#Left "Not expecting any type."))))) + +(macro: #export (struct tokens) + {#;doc "Not meant to be used directly. Prefer \"struct:\"."} + (do Monad + [tokens' (mapM Monad macro-expand tokens) + struct-type get-expected-type + tags+type (resolve-type-tags struct-type) + tags (: (Lux (List Ident)) + (case tags+type + (#Some [tags _]) + (return tags) + + _ + (fail "No tags available for type."))) + #let [tag-mappings (: (List [Text AST]) + (map (lambda [tag] [(second tag) (tag$ tag)]) + tags))] + members (mapM Monad + (: (-> AST (Lux [AST AST])) + (lambda [token] + (case token + (^ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value meta))]) + (case (get tag-name tag-mappings) + (#Some tag) + (wrap [tag value]) + + _ + (fail (Text/append "Unknown structure member: " tag-name))) + + _ + (fail "Invalid structure member.")))) + (List/join tokens'))] + (wrap (list (record$ members))))) + +(def: (Text/join parts) + (-> (List Text) Text) + (|> parts reverse (fold Text/append ""))) + +(macro: #export (struct: tokens) + {#;doc "## Definition of structures ala ML. + (struct: #export Ord (Ord Int) + (def: eq Eq) + (def: (< test subject) + (lux;< test subject)) + (def: (<= test subject) + (or (lux;< test subject) + (lux;= test subject))) + (def: (lux;> test subject) + (lux;> test subject)) + (def: (lux;>= test subject) + (or (lux;> test subject) + (lux;= test subject))))"} + (let [[exported? tokens'] (export-level^ tokens) + ?parts (: (Maybe [AST (List AST) AST AST (List AST)]) + (case tokens' + (^ (list& [_ (#FormS (list& name args))] type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs)) + (#Some name args type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs) + + (^ (list& name type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs)) + (#Some name #Nil type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs) + + (^ (list& [_ (#FormS (list& name args))] type defs)) + (#Some name args type (` {}) defs) + + (^ (list& name type defs)) + (#Some name #Nil type (` {}) defs) + + _ + #None))] + (case ?parts + (#Some [name args type meta defs]) + (case (case name + [_ (#;SymbolS ["" "_"])] + (case type + (^ [_ (#;FormS (list& [_ (#;SymbolS [_ sig-name])] sig-args))]) + (case (: (Maybe (List Text)) + (mapM Monad + (lambda [sa] + (case sa + [_ (#;SymbolS [_ arg-name])] + (#;Some arg-name) + + _ + #;None)) + sig-args)) + (^ (#;Some params)) + (#;Some (symbol$ ["" ($_ Text/append sig-name "<" (|> params (interpose ",") Text/join) ">")])) + + _ + #;None) + + _ + #;None) + + _ + (#;Some name) + ) + (#;Some name) + (let [usage (case args + #Nil + name + + _ + (` ((~ name) (~@ args))))] + (return (list (` (;;def: (~@ (export-level exported?)) (~ usage) + (~ (meta-ast-merge (` {#;struct? true}) + meta)) + (~ type) + (struct (~@ defs))))))) + + #;None + (fail "Struct must have a name other than \"_\"!")) + + #None + (fail "Wrong syntax for struct:")))) + +(def: #export (id x) + {#;doc "Identity function. Does nothing to it's argument and just returns it."} + (All [a] (-> a a)) + x) + +(do-template [
] + [(macro: #export ( tokens) + {#;doc } + (case (reverse tokens) + (^ (list& last init)) + (return (list (fold (: (-> AST AST AST) + (lambda [pre post] (` ))) + last + init))) + + _ + (fail )))] + + [and (if (~ pre) (~ post) false) "'and' requires >=1 clauses." "Short-circuiting \"and\"\n(and true false true) ## => false"] + [or (if (~ pre) true (~ post)) "'or' requires >=1 clauses." "Short-circuiting \"or\"\n(or true false true) ## => true"]) + +(macro: #export (type: tokens) + {#;doc "## The type-definition macro. + (type: (List a) + #Nil + (#Cons a (List a)))"} + (let [[exported? tokens'] (export-level^ tokens) + [rec? tokens'] (case tokens' + (#Cons [_ (#TagS [_ "rec"])] tokens') + [true tokens'] + + _ + [false tokens']) + parts (: (Maybe [Text (List AST) AST (List AST)]) + (case tokens' + (^ (list [_ (#SymbolS "" name)] [meta-cursor (#;RecordS meta-parts)] [type-cursor (#;RecordS type-parts)])) + (#Some [name #Nil [meta-cursor (#;RecordS meta-parts)] (list [type-cursor (#;RecordS type-parts)])]) + + (^ (list& [_ (#SymbolS "" name)] [meta-cursor (#;RecordS meta-parts)] type-ast1 type-asts)) + (#Some [name #Nil [meta-cursor (#;RecordS meta-parts)] (#;Cons type-ast1 type-asts)]) + + (^ (list& [_ (#SymbolS "" name)] type-asts)) + (#Some [name #Nil (` {}) type-asts]) + + (^ (list [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] [meta-cursor (#;RecordS meta-parts)] [type-cursor (#;RecordS type-parts)])) + (#Some [name args [meta-cursor (#;RecordS meta-parts)] (list [type-cursor (#;RecordS type-parts)])]) + + (^ (list& [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] [meta-cursor (#;RecordS meta-parts)] type-ast1 type-asts)) + (#Some [name args [meta-cursor (#;RecordS meta-parts)] (#;Cons type-ast1 type-asts)]) + + (^ (list& [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] type-asts)) + (#Some [name args (` {}) type-asts]) + + _ + #None))] + (case parts + (#Some name args meta type-asts) + (do Monad + [type+tags?? (unfold-type-def type-asts) + module-name current-module-name] + (let [type-name (symbol$ ["" name]) + [type tags??] type+tags?? + type-meta (: AST + (case tags?? + (#Some tags) + (` {#;tags [(~@ (map (: (-> Text AST) + (lambda' [tag] + (form$ (list (tag$ ["lux" "TextM"]) + (text$ tag))))) + tags))] + #;type? true}) + + _ + (` {#;type? true}))) + type' (: (Maybe AST) + (if rec? + (if (empty? args) + (let [g!param (symbol$ ["" ""]) + prime-name (symbol$ ["" (Text/append name "'")]) + type+ (replace-syntax (list [name (` ((~ prime-name) (~ g!param)))]) type)] + (#Some (` ((All (~ prime-name) [(~ g!param)] (~ type+)) + Void)))) + #None) + (case args + #Nil + (#Some type) + + _ + (#Some (` (All (~ type-name) [(~@ args)] (~ type)))))))] + (case type' + (#Some type'') + (return (list (` (;;def: (~@ (export-level exported?)) (~ type-name) + (~ ($_ meta-ast-merge (with-type-args args) + (if rec? (' {#;type-rec? true}) (' {})) + type-meta + meta)) + Type + (#;NamedT [(~ (text$ module-name)) + (~ (text$ name))] + (type (~ type''))))))) + + #None + (fail "Wrong syntax for type:")))) + + #None + (fail "Wrong syntax for type:")) + )) + +(type: Referrals + #All + (#Only (List Text)) + (#Exclude (List Text)) + #Nothing) + +(type: Openings + [Text (List Ident)]) + +(type: Refer + {#refer-defs Referrals + #refer-open (List Openings)}) + +(type: Importation + {#import-name Text + #import-alias (Maybe Text) + #import-refer Refer}) + +(def: (extract-defs defs) + (-> (List AST) (Lux (List Text))) + (mapM Monad + (: (-> AST (Lux Text)) + (lambda [def] + (case def + [_ (#SymbolS ["" name])] + (return name) + + _ + (fail "only/exclude requires symbols.")))) + defs)) + +(def: (parse-alias tokens) + (-> (List AST) (Lux [(Maybe Text) (List AST)])) + (case tokens + (^ (list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) + (return [(#Some alias) tokens']) + + _ + (return [#None tokens]))) + +(def: (parse-referrals tokens) + (-> (List AST) (Lux [Referrals (List AST)])) + (case tokens + (^ (list& [_ (#TagS ["" "refer"])] referral tokens')) + (case referral + [_ (#TagS "" "all")] + (return [#All tokens']) + + (^ [_ (#FormS (list& [_ (#TagS ["" "only"])] defs))]) + (do Monad + [defs' (extract-defs defs)] + (return [(#Only defs') tokens'])) + + (^ [_ (#FormS (list& [_ (#TagS ["" "exclude"])] defs))]) + (do Monad + [defs' (extract-defs defs)] + (return [(#Exclude defs') tokens'])) + + _ + (fail "Incorrect syntax for referral.")) + + _ + (return [#Nothing tokens]))) + +(def: (split-with' p ys xs) + (All [a] + (-> (-> a Bool) (List a) (List a) [(List a) (List a)])) + (case xs + #Nil + [ys xs] + + (#Cons x xs') + (if (p x) + (split-with' p (list& x ys) xs') + [ys xs]))) + +(def: (split-with p xs) + (All [a] + (-> (-> a Bool) (List a) [(List a) (List a)])) + (let [[ys' xs'] (split-with' p #Nil xs)] + [(reverse ys') xs'])) + +(def: (parse-short-referrals tokens) + (-> (List AST) (Lux [Referrals (List AST)])) + (case tokens + (^ (list& [_ (#TagS "" "+")] tokens')) + (let [[defs tokens'] (split-with symbol? tokens')] + (do Monad + [defs' (extract-defs defs)] + (return [(#Only defs') tokens']))) + + (^ (list& [_ (#TagS "" "-")] tokens')) + (let [[defs tokens'] (split-with symbol? tokens')] + (do Monad + [defs' (extract-defs defs)] + (return [(#Exclude defs') tokens']))) + + (^ (list& [_ (#TagS "" "*")] tokens')) + (return [#All tokens']) + + _ + (return [#Nothing tokens]))) + +(def: (extract-symbol syntax) + (-> AST (Lux Ident)) + (case syntax + [_ (#SymbolS ident)] + (return ident) + + _ + (fail "Not a symbol."))) + +(def: (parse-openings tokens) + (-> (List AST) (Lux [(List Openings) (List AST)])) + (case tokens + (^ (list& [_ (#TagS "" "open")] [_ (#FormS parts)] tokens')) + (if (|> parts + (map (: (-> AST Bool) + (lambda [part] + (case part + (^or [_ (#TextS _)] [_ (#SymbolS _)]) + true + + _ + false)))) + (fold (lambda [r l] (and l r)) true)) + (let [openings (fold (: (-> AST (List Openings) (List Openings)) + (lambda [part openings] + (case part + [_ (#TextS prefix)] + (list& [prefix (list)] openings) + + [_ (#SymbolS struct-name)] + (case openings + #Nil + (list ["" (list struct-name)]) + + (#Cons [prefix structs] openings') + (#Cons [prefix (#Cons struct-name structs)] openings')) + + _ + openings))) + (: (List Openings) (list)) + parts)] + (return [openings tokens'])) + (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol).")) + + _ + (return [(list) tokens]))) + +(def: (parse-short-openings parts) + (-> (List AST) (Lux [(List Openings) (List AST)])) + (if (|> parts + (map (: (-> AST Bool) + (lambda [part] + (case part + (^or [_ (#TextS _)] [_ (#SymbolS _)]) + true + + _ + false)))) + (fold (lambda [r l] (and l r)) true)) + (let [openings (fold (: (-> AST (List Openings) (List Openings)) + (lambda [part openings] + (case part + [_ (#TextS prefix)] + (list& [prefix (list)] openings) + + [_ (#SymbolS struct-name)] + (case openings + #Nil + (list ["" (list struct-name)]) + + (#Cons [prefix structs] openings') + (#Cons [prefix (#Cons struct-name structs)] openings')) + + _ + openings))) + (: (List Openings) (list)) + parts)] + (return [openings (list)])) + (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol)."))) + +(def: (decorate-sub-importations super-name) + (-> Text (List Importation) (List Importation)) + (map (: (-> Importation Importation) + (lambda [importation] + (let [{#import-name _name + #import-alias _alias + #import-refer {#refer-defs _referrals + #refer-open _openings}} importation] + {#import-name ($_ Text/append super-name "/" _name) + #import-alias _alias + #import-refer {#refer-defs _referrals + #refer-open _openings}}))))) + +(def: (replace pattern value template) + (-> Text Text Text Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value])) + +(def: (clean-module module) + (-> Text (Lux Text)) + (do Monad + [module-name current-module-name] + (case (split-module module) + (^ (list& "." parts)) + (return (|> (list& module-name parts) (interpose "/") reverse (fold Text/append ""))) + + parts + (let [[ups parts'] (split-with (Text/= "..") parts) + num-ups (length ups)] + (if (i= num-ups 0) + (return module) + (case (at num-ups (split-module-contexts module-name)) + #None + (fail (Text/append "Can't clean module: " module)) + + (#Some top-module) + (return (|> (list& top-module parts') (interpose "/") reverse (fold Text/append "")))) + ))) + )) + +(def: (parse-imports imports) + (-> (List AST) (Lux (List Importation))) + (do Monad + [imports' (mapM Monad + (: (-> AST (Lux (List Importation))) + (lambda [token] + (case token + [_ (#SymbolS "" m-name)] + (do Monad + [m-name (clean-module m-name)] + (wrap (list [m-name #None {#refer-defs #All #refer-open (list)}]))) + + (^ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))]) + (do Monad + [m-name (clean-module m-name) + alias+extra (parse-alias extra) + #let [[alias extra] alias+extra] + referral+extra (parse-referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse-openings extra) + #let [[openings extra] openings+extra] + sub-imports (parse-imports extra) + #let [sub-imports (decorate-sub-importations m-name sub-imports)]] + (wrap (case [referral alias openings] + [#Nothing #None #Nil] sub-imports + _ (list& {#import-name m-name + #import-alias alias + #import-refer {#refer-defs referral + #refer-open openings}} + sub-imports)))) + + (^ [_ (#TupleS (list& [_ (#TextS alias)] [_ (#SymbolS "" m-name)] extra))]) + (do Monad + [m-name (clean-module m-name) + referral+extra (parse-short-referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse-short-openings extra) + #let [[openings extra] openings+extra]] + (wrap (list {#import-name m-name + #import-alias (#;Some (replace ";" m-name alias)) + #import-refer {#refer-defs referral + #refer-open openings}}))) + + (^ [_ (#TupleS (list& [_ (#SymbolS "" m-name)] extra))]) + (do Monad + [m-name (clean-module m-name) + referral+extra (parse-short-referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse-short-openings extra) + #let [[openings extra] openings+extra]] + (wrap (list {#import-name m-name + #import-alias (#;Some m-name) + #import-refer {#refer-defs referral + #refer-open openings}}))) + + _ + (do Monad + [current-module current-module-name] + (fail (Text/append "Wrong syntax for import @ " current-module)))))) + imports)] + (wrap (List/join imports')))) + +(def: (exported-defs module state) + (-> Text (Lux (List Text))) + (let [modules (case state + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} + modules)] + (case (get module modules) + (#Some =module) + (let [to-alias (map (: (-> [Text Def] + (List Text)) + (lambda [[name [def-type def-meta def-value]]] + (case [(get-meta ["lux" "export?"] def-meta) + (get-meta ["lux" "hidden?"] def-meta)] + [(#Some (#BoolM true)) #;None] + (list name) + + _ + (list)))) + (let [{#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _} =module] + defs))] + (#Right state (List/join to-alias))) + + #None + (#Left ($_ Text/append "Unknown module: " module))) + )) + +(def: (filter p xs) + (All [a] (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + (list) + + (#;Cons x xs') + (if (p x) + (#;Cons x (filter p xs')) + (filter p xs')))) + +(def: (is-member? cases name) + (-> (List Text) Text Bool) + (let [output (fold (lambda [case prev] + (or prev + (Text/= case name))) + false + cases)] + output)) + +(def: (try-both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #;None (f x2) + (#;Some y) (#;Some y))) + +(def: (find-in-env name state) + (-> Text Compiler (Maybe Type)) + (case state + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} + (find (: (-> Scope (Maybe Type)) + (lambda [env] + (case env + {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} + (try-both (find (: (-> [Text Analysis] (Maybe Type)) + (lambda [[bname [[type _] _]]] + (if (Text/= name bname) + (#Some type) + #None)))) + locals + closure)))) + scopes))) + +(def: (find-def-type name state) + (-> Ident Compiler (Maybe Type)) + (let [[v-prefix v-name] name + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} state] + (case (get v-prefix modules) + #None + #None + + (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _}) + (case (get v-name defs) + #None + #None + + (#Some [def-type def-meta def-value]) + (#Some def-type))))) + +(def: (find-def-value name state) + (-> Ident (Lux [Type Unit])) + (let [[v-prefix v-name] name + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} state] + (case (get v-prefix modules) + #None + (#Left (Text/append "Unknown definition: " (Ident->Text name))) + + (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _}) + (case (get v-name defs) + #None + (#Left (Text/append "Unknown definition: " (Ident->Text name))) + + (#Some [def-type def-meta def-value]) + (#Right [state [def-type def-value]]))))) + +(def: (find-type ident) + (-> Ident (Lux Type)) + (do Monad + [#let [[module name] ident] + current-module current-module-name] + (lambda [state] + (if (Text/= "" module) + (case (find-in-env name state) + (#Some struct-type) + (#Right state struct-type) + + _ + (case (find-def-type [current-module name] state) + (#Some struct-type) + (#Right state struct-type) + + _ + (#Left ($_ Text/append "Unknown var: " (Ident->Text ident))))) + (case (find-def-type ident state) + (#Some struct-type) + (#Right state struct-type) + + _ + (#Left ($_ Text/append "Unknown var: " (Ident->Text ident))))) + ))) + +(def: (zip2 xs ys) + (All [a b] (-> (List a) (List b) (List [a b]))) + (case xs + (#Cons x xs') + (case ys + (#Cons y ys') + (list& [x y] (zip2 xs' ys')) + + _ + (list)) + + _ + (list))) + +(def: (use-field prefix [module name] type) + (-> Text Ident Type (Lux [AST AST])) + (do Monad + [output (resolve-type-tags type) + pattern (: (Lux AST) + (case output + (#Some [tags members]) + (do Monad + [slots (mapM Monad + (: (-> [Ident Type] (Lux [AST AST])) + (lambda [[sname stype]] (use-field prefix sname stype))) + (zip2 tags members))] + (return (record$ slots))) + + #None + (return (symbol$ ["" (Text/append prefix name)]))))] + (return [(tag$ [module name]) pattern]))) + +(def: (Type/show type) + (-> Type Text) + (case type + (#HostT name params) + (case params + #;Nil + name + + _ + ($_ Text/append "(" name " " (|> params (map Type/show) (interpose " ") reverse (fold Text/append "")) ")")) + + #VoidT + "Void" + + #UnitT + "Unit" + + (#SumT _) + ($_ Text/append "(| " (|> (flatten-sum type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")") + + (#ProdT _) + ($_ Text/append "[" (|> (flatten-prod type) (map Type/show) (interpose " ") reverse (fold Text/append "")) "]") + + (#LambdaT _) + ($_ Text/append "(-> " (|> (flatten-lambda type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")") + + (#BoundT id) + (Nat->Text id) + + (#VarT id) + ($_ Text/append "⌈v:" (->Text id) "⌋") + + (#ExT id) + ($_ Text/append "⟨e:" (->Text id) "⟩") + + (#UnivQ env body) + ($_ Text/append "(All " (Type/show body) ")") + + (#ExQ env body) + ($_ Text/append "(Ex " (Type/show body) ")") + + (#AppT _) + ($_ Text/append "(" (|> (flatten-app type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")") + + (#NamedT [prefix name] _) + ($_ Text/append prefix ";" name) + )) + +(macro: #hidden (^open' tokens) + (case tokens + (^ (list [_ (#SymbolS name)] [_ (#TextS prefix)] body)) + (do Monad + [struct-type (find-type name) + output (resolve-type-tags struct-type)] + (case output + (#Some [tags members]) + (do Monad + [slots (mapM Monad (: (-> [Ident Type] (Lux [AST AST])) + (lambda [[sname stype]] (use-field prefix sname stype))) + (zip2 tags members)) + #let [pattern (record$ slots)]] + (return (list (` (;_lux_case (~ (symbol$ name)) (~ pattern) (~ body)))))) + + _ + (fail (Text/append "Can only \"open\" structs: " (Type/show struct-type))))) + + _ + (fail "Wrong syntax for ^open"))) + +(macro: #export (^open tokens) + {#;doc "## Same as the \"open\" macro, but meant to be used as a pattern-matching macro for generating local bindings. + ## Can optionally take a \"prefix\" text for the generated local bindings. + (def: #export (range (^open) from to) + (All [a] (-> (Enum a) a a (List a))) + (range' <= succ from to))"} + (case tokens + (^ (list& [_ (#FormS (list [_ (#TextS prefix)]))] body branches)) + (do Monad + [g!temp (gensym "temp")] + (return (list& g!temp (` (^open' (~ g!temp) (~ (text$ prefix)) (~ body))) branches))) + + (^ (list& [_ (#FormS (list))] body branches)) + (return (list& (` (;;^open "")) body branches)) + + _ + (fail "Wrong syntax for ^open"))) + +(macro: #export (cond tokens) + {#;doc "## Branching structures with multiple test conditions. + (cond (even? num) \"even\" + (odd? num) \"odd\" + ## else-branch + \"???\")"} + (if (i= 0 (i% (length tokens) 2)) + (fail "cond requires an even number of arguments.") + (case (reverse tokens) + (^ (list& else branches')) + (return (list (fold (: (-> [AST AST] AST AST) + (lambda [branch else] + (let [[right left] branch] + (` (if (~ left) (~ right) (~ else)))))) + else + (as-pairs branches')))) + + _ + (fail "Wrong syntax for cond")))) + +(def: (enumerate' idx xs) + (All [a] (-> Nat (List a) (List [Nat a]))) + (case xs + (#Cons x xs') + (#Cons [idx x] (enumerate' (n+ +1 idx) xs')) + + #Nil + #Nil)) + +(def: (enumerate xs) + (All [a] (-> (List a) (List [Nat a]))) + (enumerate' +0 xs)) + +(macro: #export (get@ tokens) + {#;doc "## Accesses the value of a record at a given tag. + (get@ #field my-record) + + ## Can also work with multiple levels of nesting: + (get@ [#foo #bar #baz] my-record) + + ## And, if only the slot/path is given, generates an + ## accessor function: + (let [getter (get@ [#foo #bar #baz])] + (getter my-record))"} + (case tokens + (^ (list [_ (#TagS slot')] record)) + (do Monad + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags exported? type] output] + g!_ (gensym "_") + g!output (gensym "")] + (case (resolve-struct-type type) + (#Some members) + (let [pattern (record$ (map (: (-> [Ident [Nat Type]] [AST AST]) + (lambda [[[r-prefix r-name] [r-idx r-type]]] + [(tag$ [r-prefix r-name]) (if (n= idx r-idx) + g!output + g!_)])) + (zip2 tags (enumerate members))))] + (return (list (` (;_lux_case (~ record) (~ pattern) (~ g!output)))))) + + _ + (fail "get@ can only use records."))) + + (^ (list [_ (#TupleS slots)] record)) + (return (list (fold (: (-> AST AST AST) + (lambda [slot inner] + (` (;;get@ (~ slot) (~ inner))))) + record + slots))) + + (^ (list selector)) + (do Monad + [g!record (gensym "record")] + (wrap (list (` (lambda [(~ g!record)] (;;get@ (~ selector) (~ g!record))))))) + + _ + (fail "Wrong syntax for get@"))) + +(def: (open-field prefix [module name] source type) + (-> Text Ident AST Type (Lux (List AST))) + (do Monad + [output (resolve-type-tags type) + #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]] + (case output + (#Some [tags members]) + (do Monad + [decls' (mapM Monad + (: (-> [Ident Type] (Lux (List AST))) + (lambda [[sname stype]] (open-field prefix sname source+ stype))) + (zip2 tags members))] + (return (List/join decls'))) + + _ + (return (list (` (;_lux_def (~ (symbol$ ["" (Text/append prefix name)])) (~ source+) + #Nil))))))) + +(macro: #export (open tokens) + {#;doc "## Opens a structure and generates a definition for each of its members (including nested members). + ## For example: + (open Number \"i:\") + ## Will generate: + (def: i:+ (:: Number +)) + (def: i:- (:: Number -)) + (def: i:* (:: Number *)) + ..."} + (case tokens + (^ (list& [_ (#SymbolS struct-name)] tokens')) + (do Monad + [@module current-module-name + #let [prefix (case tokens' + (^ (list [_ (#TextS prefix)])) + prefix + + _ + "")] + struct-type (find-type struct-name) + output (resolve-type-tags struct-type) + #let [source (symbol$ struct-name)]] + (case output + (#Some [tags members]) + (do Monad + [decls' (mapM Monad (: (-> [Ident Type] (Lux (List AST))) + (lambda [[sname stype]] (open-field prefix sname source stype))) + (zip2 tags members))] + (return (List/join decls'))) + + _ + (fail (Text/append "Can only \"open\" structs: " (Type/show struct-type))))) + + _ + (fail "Wrong syntax for open"))) + +(macro: #export (|>. tokens) + {#;doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it. + (|> (map ->Text) (interpose \" \") (fold Text/append \"\")) + ## => + (lambda [] + (fold Text/append \"\" + (interpose \" \" + (map ->Text ))))"} + (do Monad + [g!arg (gensym "arg")] + (return (list (` (lambda [(~ g!arg)] (|> (~ g!arg) (~@ tokens)))))))) + +(def: (imported-by? import-name module-name) + (-> Text Text (Lux Bool)) + (do Monad + [module (find-module module-name) + #let [{#module-hash _ #module-aliases _ #defs _ #imports imports #tags _ #types _ #module-anns _} module]] + (wrap (is-member? imports import-name)))) + +(macro: #export (default tokens state) + {#;doc "## Allows you to provide a default value that will be used + ## if a (Maybe x) value turns out to be #;Some. + (default 20 (#;Some 10)) => 10 + + (default 20 #;None) => 20"} + (case tokens + (^ (list else maybe)) + (let [g!temp (: AST [["" -1 -1] (#;SymbolS ["" ""])]) + code (` (case (~ maybe) + (#;Some (~ g!temp)) + (~ g!temp) + + #;None + (~ else)))] + (#;Right [state (list code)])) + + _ + (#;Left "Wrong syntax for ?"))) + +(def: (read-refer module-name options) + (-> Text (List AST) (Lux Refer)) + (do Monad + [referral+options (parse-referrals options) + #let [[referral options] referral+options] + openings+options (parse-openings options) + #let [[openings options] openings+options] + current-module current-module-name + #let [test-referrals (: (-> Text (List Text) (List Text) (Lux (List Unit))) + (lambda [module-name all-defs referred-defs] + (mapM Monad + (: (-> Text (Lux Unit)) + (lambda [_def] + (if (is-member? all-defs _def) + (return []) + (fail ($_ Text/append _def " is not defined in module " module-name " @ " current-module))))) + referred-defs)))]] + (case options + #;Nil + (wrap {#refer-defs referral + #refer-open openings}) + + _ + (fail ($_ Text/append "Wrong syntax for refer @ " current-module + "\n" (|> options + (map ast-to-text) + (interpose " ") + (fold Text/append ""))))))) + +(def: (write-refer module-name [r-defs r-opens]) + (-> Text Refer (Lux (List AST))) + (do Monad + [current-module current-module-name + #let [test-referrals (: (-> Text (List Text) (List Text) (Lux (List Unit))) + (lambda [module-name all-defs referred-defs] + (mapM Monad + (: (-> Text (Lux Unit)) + (lambda [_def] + (if (is-member? all-defs _def) + (return []) + (fail ($_ Text/append _def " is not defined in module " module-name " @ " current-module))))) + referred-defs)))] + defs' (case r-defs + #All + (exported-defs module-name) + + (#Only +defs) + (do Monad + [*defs (exported-defs module-name) + _ (test-referrals module-name *defs +defs)] + (wrap +defs)) + + (#Exclude -defs) + (do Monad + [*defs (exported-defs module-name) + _ (test-referrals module-name *defs -defs)] + (wrap (filter (|>. (is-member? -defs) not) *defs))) + + #Nothing + (wrap (list))) + #let [defs (map (: (-> Text AST) + (lambda [def] + (` (;_lux_def (~ (symbol$ ["" def])) + (~ (symbol$ [module-name def])) + (#Cons [["lux" "alias"] (#IdentM [(~ (text$ module-name)) (~ (text$ def))])] + #Nil))))) + defs') + openings (join-map (: (-> Openings (List AST)) + (lambda [[prefix structs]] + (map (lambda [[_ name]] (` (open (~ (symbol$ [module-name name])) (~ (text$ prefix))))) + structs))) + r-opens)]] + (wrap (List/append defs openings)) + )) + +(macro: #export (refer tokens) + (case tokens + (^ (list& [_ (#TextS module-name)] options)) + (do Monad + [=refer (read-refer module-name options)] + (write-refer module-name =refer)) + + _ + (fail "Wrong syntax for refer"))) + +(def: (refer-to-ast module-name [r-defs r-opens]) + (-> Text Refer AST) + (let [=defs (: (List AST) + (case r-defs + #All + (list (' #refer) (' #all)) + + (#Only defs) + (list (' #refer) (`' (#only (~@ (map (|>. [""] symbol$) + defs))))) + + (#Exclude defs) + (list (' #refer) (`' (#exclude (~@ (map (|>. [""] symbol$) + defs))))) + + #Nothing + (list))) + =opens (join-map (lambda [[prefix structs]] + (list& (text$ prefix) (map symbol$ structs))) + r-opens)] + (` (;;refer (~ (text$ module-name)) + (~@ =defs) + (~' #open) ((~@ =opens)))))) + +(macro: #export (module: tokens) + {#;doc "## Examples + (;module: {#;doc \"Some documentation...\"} + lux + (lux (control (monad #as M #refer #all)) + (data (text #open (\"Text/\" Monoid)) + (struct (list #open (\"List/\" Monad))) + maybe + (ident #open (\"Ident/\" Codec))) + meta + (macro ast)) + (.. (type #open (\"\" Eq)))) + + (;module: {#;doc \"Some documentation...\"} + lux + (lux (control [\"M\" monad #*]) + (data [text \"Text/\" Monoid] + (struct [list \"List/\" Monad]) + maybe + [ident \"Ident/\" Codec]) + meta + (macro ast)) + (.. [type \"\" Eq]))"} + (do Monad + [#let [[_meta _imports] (: [(List [AST AST]) (List AST)] + (case tokens + (^ (list& [_ (#RecordS _meta)] _imports)) + [_meta _imports] + + _ + [(list) tokens]))] + imports (parse-imports _imports) + #let [=imports (map (: (-> Importation AST) + (lambda [[m-name m-alias =refer]] + (` [(~ (text$ m-name)) (~ (text$ (default "" m-alias)))]))) + imports) + =refers (map (: (-> Importation AST) + (lambda [[m-name m-alias =refer]] + (refer-to-ast m-name =refer))) + imports)] + =meta (process-def-meta (record$ (list& [(` #;imports) (` [(~@ =imports)])] + _meta))) + #let [=module (` (;_lux_module (~ =meta)))]] + (wrap (#;Cons =module =refers)))) + +(macro: #export (:: tokens) + {#;doc "## Allows accessing the value of a structure's member. + (:: Codec encode) + + ## Also allows using that value as a function. + (:: Codec encode 123)"} + (case tokens + (^ (list struct [_ (#SymbolS member)])) + (return (list (` (let [(^open) (~ struct)] (~ (symbol$ member)))))) + + (^ (list& struct [_ (#SymbolS member)] args)) + (return (list (` ((let [(^open) (~ struct)] (~ (symbol$ member))) (~@ args))))) + + _ + (fail "Wrong syntax for ::"))) + +(macro: #export (set@ tokens) + {#;doc "## Sets the value of a record at a given tag. + (set@ #name \"Lux\" lang) + + ## Can also work with multiple levels of nesting: + (set@ [#foo #bar #baz] value my-record) + + ## And, if only the slot/path and (optionally) the value are given, generates a + ## mutator function: + (let [setter (set@ [#foo #bar #baz] value)] + (setter my-record)) + + (let [setter (set@ [#foo #bar #baz])] + (setter value my-record))"} + (case tokens + (^ (list [_ (#TagS slot')] value record)) + (do Monad + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags exported? type] output]] + (case (resolve-struct-type type) + (#Some members) + (do Monad + [pattern' (mapM Monad + (: (-> [Ident [Nat Type]] (Lux [Ident Nat AST])) + (lambda [[r-slot-name [r-idx r-type]]] + (do Monad + [g!slot (gensym "")] + (return [r-slot-name r-idx g!slot])))) + (zip2 tags (enumerate members)))] + (let [pattern (record$ (map (: (-> [Ident Nat AST] [AST AST]) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) r-var])) + pattern')) + output (record$ (map (: (-> [Ident Nat AST] [AST AST]) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) (if (n= idx r-idx) + value + r-var)])) + pattern'))] + (return (list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) + + _ + (fail "set@ can only use records."))) + + (^ (list [_ (#TupleS slots)] value record)) + (case slots + #;Nil + (fail "Wrong syntax for set@") + + _ + (do Monad + [bindings (mapM Monad + (: (-> AST (Lux AST)) + (lambda [_] (gensym "temp"))) + slots) + #let [pairs (zip2 slots bindings) + update-expr (fold (: (-> [AST AST] AST AST) + (lambda [[s b] v] + (` (;;set@ (~ s) (~ v) (~ b))))) + value + (reverse pairs)) + [_ accesses'] (fold (: (-> [AST AST] [AST (List (List AST))] [AST (List (List AST))]) + (lambda [[new-slot new-binding] [old-record accesses']] + [(` (get@ (~ new-slot) (~ new-binding))) + (#;Cons (list new-binding old-record) accesses')])) + [record (: (List (List AST)) #;Nil)] + pairs) + accesses (List/join (reverse accesses'))]] + (wrap (list (` (let [(~@ accesses)] + (~ update-expr))))))) + + (^ (list selector value)) + (do Monad + [g!record (gensym "record")] + (wrap (list (` (lambda [(~ g!record)] (;;set@ (~ selector) (~ value) (~ g!record))))))) + + (^ (list selector)) + (do Monad + [g!value (gensym "value") + g!record (gensym "record")] + (wrap (list (` (lambda [(~ g!value) (~ g!record)] (;;set@ (~ selector) (~ g!value) (~ g!record))))))) + + _ + (fail "Wrong syntax for set@"))) + +(macro: #export (update@ tokens) + {#;doc "## Modifies the value of a record at a given tag, based on some function. + (update@ #age inc person) + + ## Can also work with multiple levels of nesting: + (update@ [#foo #bar #baz] func my-record) + + ## And, if only the slot/path and (optionally) the value are given, generates a + ## mutator function: + (let [updater (update@ [#foo #bar #baz] func)] + (updater my-record)) + + (let [updater (update@ [#foo #bar #baz])] + (updater func my-record))"} + (case tokens + (^ (list [_ (#TagS slot')] fun record)) + (do Monad + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags exported? type] output]] + (case (resolve-struct-type type) + (#Some members) + (do Monad + [pattern' (mapM Monad + (: (-> [Ident [Nat Type]] (Lux [Ident Nat AST])) + (lambda [[r-slot-name [r-idx r-type]]] + (do Monad + [g!slot (gensym "")] + (return [r-slot-name r-idx g!slot])))) + (zip2 tags (enumerate members)))] + (let [pattern (record$ (map (: (-> [Ident Nat AST] [AST AST]) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) r-var])) + pattern')) + output (record$ (map (: (-> [Ident Nat AST] [AST AST]) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) (if (n= idx r-idx) + (` ((~ fun) (~ r-var))) + r-var)])) + pattern'))] + (return (list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) + + _ + (fail "update@ can only use records."))) + + (^ (list [_ (#TupleS slots)] fun record)) + (case slots + #;Nil + (fail "Wrong syntax for update@") + + _ + (do Monad + [g!record (gensym "record") + g!temp (gensym "temp")] + (wrap (list (` (let [(~ g!record) (~ record) + (~ g!temp) (get@ [(~@ slots)] (~ g!record))] + (set@ [(~@ slots)] ((~ fun) (~ g!temp)) (~ g!record)))))))) + + (^ (list selector fun)) + (do Monad + [g!record (gensym "record")] + (wrap (list (` (lambda [(~ g!record)] (;;update@ (~ selector) (~ fun) (~ g!record))))))) + + (^ (list selector)) + (do Monad + [g!fun (gensym "fun") + g!record (gensym "record")] + (wrap (list (` (lambda [(~ g!fun) (~ g!record)] (;;update@ (~ selector) (~ g!fun) (~ g!record))))))) + + _ + (fail "Wrong syntax for update@"))) + +(macro: #export (^template tokens) + {#;doc "## It's similar to do-template, but meant to be used during pattern-matching. + (def: (beta-reduce env type) + (-> (List Type) Type Type) + (case type + (#;HostT name params) + (#;HostT name (List/map (beta-reduce env) params)) + + (^template [] + ( left right) + ( (beta-reduce env left) (beta-reduce env right))) + ([#;SumT] [#;ProdT]) + + (^template [] + ( left right) + ( (beta-reduce env left) (beta-reduce env right))) + ([#;LambdaT] + [#;AppT]) + + (^template [] + ( old-env def) + (case old-env + #;Nil + ( env def) + + _ + type)) + ([#;UnivQ] + [#;ExQ]) + + (#;BoundT idx) + (default type (list;at idx env)) + + (#;NamedT name type) + (beta-reduce env type) + + _ + type + ))"} + (case tokens + (^ (list& [_ (#FormS (list& [_ (#TupleS bindings)] templates))] + [_ (#FormS data)] + branches)) + (case (: (Maybe (List AST)) + (do Monad + [bindings' (mapM Monad get-name bindings) + data' (mapM Monad tuple->list data)] + (if (every? (i= (length bindings')) (map length data')) + (let [apply (: (-> RepEnv (List AST)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + wrap)) + #;None))) + (#Some output) + (return (List/append output branches)) + + #None + (fail "Wrong syntax for ^template")) + + _ + (fail "Wrong syntax for ^template"))) + +(do-template [ ] + [(def: #export ( n) + (-> ) + (_lux_proc ["jvm" ] [n]))] + + [real-to-int Real Int "d2l"] + [int-to-real Int Real "l2d"] + ) + +(do-template [ <=-name> <=> + <<-doc> <<=-doc> <>-doc> <>=-doc>] + [(def: #export (<=-name> test subject) + {#;doc } + (-> Bool) + (_lux_proc [ <=>] [subject test])) + + (def: #export ( test subject) + {#;doc <<-doc>} + (-> Bool) + (_lux_proc [ ] [subject test])) + + (def: #export ( test subject) + {#;doc <<=-doc>} + (-> Bool) + (or (_lux_proc [ ] [subject test]) + (_lux_proc [ <=>] [subject test]))) + + (def: #export ( test subject) + {#;doc <>-doc>} + (-> Bool) + (_lux_proc [ ] [test subject])) + + (def: #export ( test subject) + {#;doc <>=-doc>} + (-> Bool) + (or (_lux_proc [ ] [test subject]) + (_lux_proc [ <=>] [subject test])))] + + [ Nat "nat" =+ "=" <+ <=+ "<" >+ >=+ + "Natural equality." "Natural less-than." "Natural less-than-equal." "Natural greater-than." "Natural greater-than-equal."] + + [ Int "jvm" = "leq" < <= "llt" > >= + "Integer equality." "Integer less-than." "Integer less-than-equal." "Integer greater-than." "Integer greater-than-equal."] + + [Frac "frac" =.. "=" <.. <=.. "<" >.. >=.. + "Fractional equality." "Fractional less-than." "Fractional less-than-equal." "Fractional greater-than." "Fractional greater-than-equal."] + + [Real "jvm" =. "deq" <. <=. "dlt" >. >=. + "Real equality." "Real less-than." "Real less-than-equal." "Real greater-than." "Real greater-than-equal."] + ) + +(do-template [ ] + [(def: #export ( param subject) + {#;doc } + (-> ) + (_lux_proc [subject param]))] + + [ Nat ++ ["nat" "+"] "Nat(ural) addition."] + [ Nat -+ ["nat" "-"] "Nat(ural) substraction."] + [ Nat *+ ["nat" "*"] "Nat(ural) multiplication."] + [ Nat /+ ["nat" "/"] "Nat(ural) division."] + [ Nat %+ ["nat" "%"] "Nat(ural) remainder."] + + [ Int + ["jvm" "ladd"] "Int(eger) addition."] + [ Int - ["jvm" "lsub"] "Int(eger) substraction."] + [ Int * ["jvm" "lmul"] "Int(eger) multiplication."] + [ Int / ["jvm" "ldiv"] "Int(eger) division."] + [ Int % ["jvm" "lrem"] "Int(eger) remainder."] + + [Frac +.. ["frac" "+"] "Frac(tional) addition."] + [Frac -.. ["frac" "-"] "Frac(tional) substraction."] + [Frac *.. ["frac" "*"] "Frac(tional) multiplication."] + [Frac /.. ["frac" "/"] "Frac(tional) division."] + [Frac %.. ["frac" "%"] "Frac(tional) remainder."] + + [Real +. ["jvm" "dadd"] "Real addition."] + [Real -. ["jvm" "dsub"] "Real substraction."] + [Real *. ["jvm" "dmul"] "Real multiplication."] + [Real /. ["jvm" "ddiv"] "Real division."] + [Real %. ["jvm" "drem"] "Real remainder."] + ) + +(do-template [ ] + [(def: #export ( left right) + {#;doc } + (-> ) + (if ( right left) + left + right))] + + [min+ Nat <+ "Nat(ural) minimum."] + [max+ Nat >+ "Nat(ural) maximum."] + + [min Int < "Int(eger) minimum."] + [max Int > "Int(eger) maximum."] + + [min.. Frac <.. "Frac(tional) minimum."] + [max.. Frac >.. "Frac(tional) maximum."] + + [min. Real <. "Real minimum."] + [max. Real >. "Real minimum."] + ) + +(def: (find-baseline-column ast) + (-> AST Int) + (case ast + (^template [] + [[_ _ column] ( _)] + column) + ([#BoolS] + [#NatS] + [#IntS] + [#FracS] + [#RealS] + [#CharS] + [#TextS] + [#SymbolS] + [#TagS]) + + (^template [] + [[_ _ column] ( parts)] + (fold min column (map find-baseline-column parts))) + ([#FormS] + [#TupleS]) + + [[_ _ column] (#RecordS pairs)] + (fold min column + (List/append (map (. find-baseline-column first) pairs) + (map (. find-baseline-column second) pairs))) + )) + +(type: Doc-Fragment + (#Doc-Comment Text) + (#Doc-Example AST)) + +(def: (identify-doc-fragment ast) + (-> AST Doc-Fragment) + (case ast + [_ (#;TextS comment)] + (#Doc-Comment comment) + + _ + (#Doc-Example ast))) + +(def: (Char/encode x) + (-> Char Text) + (let [as-text (case x + #"\t" "\\t" + #"\b" "\\b" + #"\n" "\\n" + #"\r" "\\r" + #"\f" "\\f" + #"\"" "\\\"" + #"\\" "\\\\" + _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))] + ($_ Text/append "#\"" as-text "\""))) + +(def: (Text/encode original) + (-> Text Text) + (let [escaped (|> original + (replace "\t" "\\t") + (replace "\b" "\\b") + (replace "\n" "\\n") + (replace "\r" "\\r") + (replace "\f" "\\f") + (replace "\"" "\\\"") + (replace "\\" "\\\\") + )] + ($_ Text/append "\"" escaped "\""))) + +(do-template [ ] + [(def: #export + (-> Int Int) + (i+ ))] + + [inc 1] + [dec -1]) + +(def: tag->Text + (-> Ident Text) + (. (Text/append "#") Ident->Text)) + +(def: (repeat n x) + (All [a] (-> Int a (List a))) + (if (i> n 0) + (#;Cons x (repeat (i+ -1 n) x)) + #;Nil)) + +(def: (cursor-padding baseline [_ old-line old-column] [_ new-line new-column]) + (-> Int Cursor Cursor Text) + (if (i= old-line new-line) + (Text/join (repeat (i- new-column old-column) " ")) + (let [extra-lines (Text/join (repeat (i- new-line old-line) "\n")) + space-padding (Text/join (repeat (i- new-column baseline) " "))] + (Text/append extra-lines space-padding)))) + +(def: (Text/size x) + (-> Text Int) + (_lux_proc ["jvm" "i2l"] + [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])])) + +(def: (Text/trim x) + (-> Text Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:trim:"] [x])) + +(def: (update-cursor [file line column] ast-text) + (-> Cursor Text Cursor) + [file line (i+ column (Text/size ast-text))]) + +(def: (delim-update-cursor [file line column]) + (-> Cursor Cursor) + [file line (inc column)]) + +(def: rejoin-all-pairs + (-> (List [AST AST]) (List AST)) + (. List/join (map rejoin-pair))) + +(def: (doc-example->Text prev-cursor baseline example) + (-> Cursor Int AST [Cursor Text]) + (case example + (^template [ ] + [new-cursor ( value)] + (let [as-text ( value)] + [(update-cursor new-cursor as-text) + (Text/append (cursor-padding baseline prev-cursor new-cursor) + as-text)])) + ([#BoolS ->Text] + [#NatS Nat->Text] + [#IntS ->Text] + [#FracS Frac->Text] + [#RealS ->Text] + [#CharS Char/encode] + [#TextS Text/encode] + [#SymbolS Ident->Text] + [#TagS tag->Text]) + + (^template [ ] + [group-cursor ( parts)] + (let [[group-cursor' parts-text] (fold (lambda [part [last-cursor text-accum]] + (let [[part-cursor part-text] (doc-example->Text last-cursor baseline part)] + [part-cursor (Text/append text-accum part-text)])) + [(delim-update-cursor group-cursor) ""] + ( parts))] + [(delim-update-cursor group-cursor') + ($_ Text/append (cursor-padding baseline prev-cursor group-cursor) + + parts-text + )])) + ([#FormS "(" ")" id] + [#TupleS "[" "]" id] + [#RecordS "{" "}" rejoin-all-pairs]) + )) + +(def: (with-baseline baseline [file line column]) + (-> Int Cursor Cursor) + [file line baseline]) + +(def: (doc-fragment->Text fragment) + (-> Doc-Fragment Text) + (case fragment + (#Doc-Comment comment) + (|> comment + (split-text "\n") + (map (lambda [line] ($_ Text/append "## " line "\n"))) + Text/join) + + (#Doc-Example example) + (let [baseline (find-baseline-column example) + [cursor _] example + [_ text] (doc-example->Text (with-baseline baseline cursor) baseline example)] + (Text/append text "\n\n")))) + +(macro: #export (doc tokens) + {#;doc "Creates code documentation, embedding text as comments and properly formatting the forms it's being given. + + ## For Example: + (doc + \"Allows arbitrary looping, using the \\\"recur\\\" form to re-start the loop. + Can be used in monadic code to create monadic loops.\" + (loop [count 0 + x init] + (if (< 10 count) + (recur (inc count) (f x)) + x)))"} + (return (list (` (#;TextM (~ (|> tokens + (map (. doc-fragment->Text identify-doc-fragment)) + Text/join + Text/trim + text$))))))) + +(def: (interleave xs ys) + (All [a] (-> (List a) (List a) (List a))) + (case xs + #Nil + #Nil + + (#Cons x xs') + (case ys + #Nil + #Nil + + (#Cons y ys') + (list& x y (interleave xs' ys'))))) + +(def: (type->ast type) + (-> Type AST) + (case type + (#HostT name params) + (` (#HostT (~ (text$ name)) (~ (untemplate-list (map type->ast params))))) + + #VoidT + (` #VoidT) + + #UnitT + (` #UnitT) + + (^template [] + ( left right) + (` ( (~ (type->ast left)) (~ (type->ast right))))) + ([#SumT] [#ProdT]) + + (#LambdaT in out) + (` (#LambdaT (~ (type->ast in)) (~ (type->ast out)))) + + (#BoundT idx) + (` (#BoundT (~ (nat$ idx)))) + + (#VarT id) + (` (#VarT (~ (nat$ id)))) + + (#ExT id) + (` (#ExT (~ (nat$ id)))) + + (#UnivQ env type) + (let [env' (untemplate-list (map type->ast env))] + (` (#UnivQ (~ env') (~ (type->ast type))))) + + (#ExQ env type) + (let [env' (untemplate-list (map type->ast env))] + (` (#ExQ (~ env') (~ (type->ast type))))) + + (#AppT fun arg) + (` (#AppT (~ (type->ast fun)) (~ (type->ast arg)))) + + (#NamedT [module name] type) + (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->ast type)))) + )) + +(macro: #export (loop tokens) + {#;doc (doc "Allows arbitrary looping, using the \"recur\" form to re-start the loop." + "Can be used in monadic code to create monadic loops." + (loop [count 0 + x init] + (if (< 10 count) + (recur (inc count) (f x)) + x)))} + (case tokens + (^ (list [_ (#TupleS bindings)] body)) + (let [pairs (as-pairs bindings) + vars (map first pairs) + inits (map second pairs)] + (if (every? symbol? inits) + (do Monad + [inits' (: (Lux (List Ident)) + (case (mapM Monad get-ident inits) + (#Some inits') (return inits') + #None (fail "Wrong syntax for loop"))) + init-types (mapM Monad find-type inits') + expected get-expected-type] + (return (list (` ((;_lux_: (-> (~@ (map type->ast init-types)) + (~ (type->ast expected))) + (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] + (~ body))) + (~@ inits)))))) + (do Monad + [aliases (mapM Monad + (: (-> AST (Lux AST)) + (lambda [_] (gensym ""))) + inits)] + (return (list (` (let [(~@ (interleave aliases inits))] + (;loop [(~@ (interleave vars aliases))] + (~ body))))))))) + + _ + (fail "Wrong syntax for loop"))) + +(macro: #export (^slots tokens) + {#;doc (doc "Allows you to extract record members as local variables with the same names." + "For example:" + (let [(^slots [#foo #bar #baz]) quux] + (f foo bar baz)))} + (case tokens + (^ (list& [_ (#FormS (list [_ (#TupleS (list& hslot' tslots'))]))] body branches)) + (do Monad + [slots (: (Lux [Ident (List Ident)]) + (case (: (Maybe [Ident (List Ident)]) + (do Monad + [hslot (get-tag hslot') + tslots (mapM Monad get-tag tslots')] + (wrap [hslot tslots]))) + (#Some slots) + (return slots) + + #None + (fail "Wrong syntax for ^slots"))) + #let [[hslot tslots] slots] + hslot (normalize hslot) + tslots (mapM Monad normalize tslots) + output (resolve-tag hslot) + g!_ (gensym "_") + #let [[idx tags exported? type] output + slot-pairings (map (: (-> Ident [Text AST]) + (lambda [[module name]] [name (symbol$ ["" name])])) + (list& hslot tslots)) + pattern (record$ (map (: (-> Ident [AST AST]) + (lambda [[module name]] + (let [tag (tag$ [module name])] + (case (get name slot-pairings) + (#Some binding) [tag binding] + #None [tag g!_])))) + tags))]] + (return (list& pattern body branches))) + + _ + (fail "Wrong syntax for ^slots"))) + +(def: (place-tokens label tokens target) + (-> Text (List AST) AST (Maybe (List AST))) + (case target + (^or [_ (#BoolS _)] [_ (#NatS _)] [_ (#IntS _)] [_ (#FracS _)] [_ (#RealS _)] [_ (#CharS _)] [_ (#TextS _)] [_ (#TagS _)]) + (#Some (list target)) + + [_ (#SymbolS [prefix name])] + (if (and (Text/= "" prefix) + (Text/= label name)) + (#Some tokens) + (#Some (list target))) + + (^template [ ] + [_ ( elems)] + (do Monad + [placements (mapM Monad (place-tokens label tokens) elems)] + (wrap (list ( (List/join placements)))))) + ([#TupleS tuple$] + [#FormS form$]) + + [_ (#RecordS pairs)] + (do Monad + [=pairs (mapM Monad + (: (-> [AST AST] (Maybe [AST AST])) + (lambda [[slot value]] + (do Monad + [slot' (place-tokens label tokens slot) + value' (place-tokens label tokens value)] + (case [slot' value'] + (^ [(list =slot) (list =value)]) + (wrap [=slot =value]) + + _ + #None)))) + pairs)] + (wrap (list (record$ =pairs)))) + )) + +(macro: #export (let% tokens) + {#;doc (doc "Controlled macro-expansion." + "Bind an arbitraty number of ASTs resulting from macro-expansion to local bindings." + "Wherever a binding appears, the bound ASTs will be spliced in there." + (test: "AST operations & structures" + (let% [ (do-template [ ] + [(compare ) + (compare (:: AST/Show show )) + (compare true (:: Eq = ))] + + [(bool true) "true" [["" -1 -1] (#;BoolS true)]] + [(bool false) "false" [_ (#;BoolS false)]] + [(int 123) "123" [_ (#;IntS 123)]] + [(real 123.0) "123.0" [_ (#;RealS 123.0)]] + [(char #"\n") "#\"\\n\"" [_ (#;CharS #"\n")]] + [(text "\n") "\"\\n\"" [_ (#;TextS "\n")]] + [(tag ["yolo" "lol"]) "#yolo;lol" [_ (#;TagS ["yolo" "lol"])]] + [(symbol ["yolo" "lol"]) "yolo;lol" [_ (#;SymbolS ["yolo" "lol"])]] + [(form (list (bool true) (int 123))) "(true 123)" (^ [_ (#;FormS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])] + [(tuple (list (bool true) (int 123))) "[true 123]" (^ [_ (#;TupleS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])] + [(record (list [(bool true) (int 123)])) "{true 123}" (^ [_ (#;RecordS (list [[_ (#;BoolS true)] [_ (#;IntS 123)]]))])] + [(local-tag "lol") "#lol" [_ (#;TagS ["" "lol"])]] + [(local-symbol "lol") "lol" [_ (#;SymbolS ["" "lol"])]] + )] + (test-all ))))} + (case tokens + (^ (list& [_ (#TupleS bindings)] bodies)) + (case bindings + (^ (list& [_ (#SymbolS ["" var-name])] macro-expr bindings')) + (do Monad + [expansion (macro-expand-once macro-expr)] + (case (place-tokens var-name expansion (` (;let% [(~@ bindings')] (~@ bodies)))) + (#Some output) + (wrap output) + + _ + (fail "[let%] Improper macro expansion."))) + + #Nil + (return bodies) + + _ + (fail "Wrong syntax for let%")) + + _ + (fail "Wrong syntax for let%"))) + +(def: (flatten-alias type) + (-> Type Type) + (case type + (^template [] + (#NamedT ["lux" ] _) + type) + (["Bool"] + ["Nat"] + ["Int"] + ["Frac"] + ["Real"] + ["Char"] + ["Text"]) + + (#NamedT _ type') + type' + + _ + type)) + +(def: (anti-quote-def name) + (-> Ident (Lux AST)) + (do Monad + [type+value (find-def-value name) + #let [[type value] type+value]] + (case (flatten-alias type) + (^template [ ] + (#NamedT ["lux" ] _) + (wrap ( (:! value)))) + (["Bool" Bool bool$] + ["Nat" Nat nat$] + ["Int" Int int$] + ["Frac" Frac frac$] + ["Real" Real real$] + ["Char" Char char$] + ["Text" Text text$]) + + _ + (fail (Text/append "Can't anti-quote type: " (Ident->Text name)))))) + +(def: (anti-quote token) + (-> AST (Lux AST)) + (case token + [_ (#SymbolS [def-prefix def-name])] + (if (Text/= "" def-prefix) + (:: Monad return token) + (anti-quote-def [def-prefix def-name])) + + (^template [] + [meta ( parts)] + (do Monad + [=parts (mapM Monad anti-quote parts)] + (wrap [meta ( =parts)]))) + ([#FormS] + [#TupleS]) + + [meta (#RecordS pairs)] + (do Monad + [=pairs (mapM Monad + (: (-> [AST AST] (Lux [AST AST])) + (lambda [[slot value]] + (do Monad + [=value (anti-quote value)] + (wrap [slot =value])))) + pairs)] + (wrap [meta (#RecordS =pairs)])) + + _ + (:: Monad return token) + )) + +(macro: #export (^~ tokens) + {#;doc (doc "Use global defs with simple values, such as text, int, real, bool and char, in place of literals in patterns." + "The definitions must be properly-qualified (though you may use one of the short-cuts Lux provides)." + (def: (empty?' node) + (All [K V] (-> (Node K V) Bool)) + (case node + (^~ (#Base ;;clean-bitmap _)) + true + + _ + false)))} + (case tokens + (^ (list& [_ (#FormS (list pattern))] body branches)) + (do Monad + [module-name current-module-name + pattern+ (macro-expand-all pattern)] + (case pattern+ + (^ (list pattern')) + (do Monad + [pattern'' (anti-quote pattern')] + (wrap (list& pattern'' body branches))) + + _ + (fail "^~ can only expand to 1 pattern."))) + + _ + (fail "Wrong syntax for ^~"))) + +(type: MultiLevelCase + [AST (List [AST AST])]) + +(def: (case-level^ level) + (-> AST (Lux [AST AST])) + (case level + (^ [_ (#;RecordS (list [expr binding]))]) + (return [expr binding]) + + _ + (return [level (` true)]) + )) + +(def: (multi-level-case^ levels) + (-> (List AST) (Lux MultiLevelCase)) + (case levels + #;Nil + (fail "Multi-level patterns can't be empty.") + + (#;Cons init extras) + (do Monad + [extras' (mapM Monad case-level^ extras)] + (wrap [init extras'])))) + +(def: (multi-level-case$ g!_ [[init-pattern levels] body]) + (-> AST [MultiLevelCase AST] (List AST)) + (let [inner-pattern-body (fold (lambda [[calculation pattern] success] + (` (case (~ calculation) + (~ pattern) + (~ success) + + (~ g!_) + #;None))) + (` (#;Some (~ body))) + (: (List [AST AST]) (reverse levels)))] + (list init-pattern inner-pattern-body))) + +(macro: #export (^=> tokens) + {#;doc (doc "Multi-level pattern matching." + "Useful in situations where the result of a branch depends on further refinements on the values being matched." + "For example:" + (case (split (size static) uri) + (^=> (#;Some [chunk uri']) {(Text/= static chunk) true}) + (match-uri endpoint? parts' uri') + + _ + (#;Left (format "Static part " (%t static) " doesn't match URI: " uri))) + + "Short-cuts can be taken when using boolean tests." + "The example above can be rewritten as..." + (case (split (size static) uri) + (^=> (#;Some [chunk uri']) (Text/= static chunk)) + (match-uri endpoint? parts' uri') + + _ + (#;Left (format "Static part " (%t static) " doesn't match URI: " uri))))} + (case tokens + (^ (list& [_meta (#;FormS levels)] body next-branches)) + (do Monad + [mlc (multi-level-case^ levels) + expected get-expected-type + g!temp (gensym "temp")] + (let [output (list g!temp + (` (;_lux_case (;_lux_: (#;AppT Maybe (~ (type->ast expected))) + (case (~ g!temp) + (~@ (multi-level-case$ g!temp [mlc body])) + + (~ g!temp) + #;None)) + (#;Some (~ g!temp)) + (~ g!temp) + + #;None + (case (~ g!temp) + (~@ next-branches)))))] + (wrap output))) + + _ + (fail "Wrong syntax for ^=>"))) + +(macro: #export (ident-for tokens) + {#;doc (doc "Given a symbol or a tag, gives back a 2 tuple with the prefix and name parts, both as Text." + (ident-for #;doc) + "=>" + ["lux" "doc"])} + (case tokens + (^template [] + (^ (list [_ ( [prefix name])])) + (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))) + ([#;SymbolS] [#;TagS]) + + _ + (fail "Wrong syntax for ident-for"))) + +(do-template [ <%> <=> <0> <2>] + [(def: #export ( n) + (-> Bool) + (<=> <0> (<%> n <2>))) + + (def: #export ( n) + (-> Bool) + (not ( n)))] + + [Nat even?+ odd?+ n% n= +0 +2] + [Int even? odd? i% i= 0 2]) + +(def: (get-scope-type-vars state) + (Lux (List Nat)) + (case state + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} + (#Right state scope-type-vars) + )) + +(def: (list-at idx xs) + (All [a] (-> Int (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons x xs') + (if (i= 0 idx) + (#;Some x) + (list-at (dec idx) xs')))) + +(macro: #export ($ tokens) + (case tokens + (^ (list [_ (#IntS idx)])) + (do Monad + [stvs get-scope-type-vars] + (case (list-at idx (reverse stvs)) + (#;Some var-id) + (wrap (list (` (#ExT (~ (nat$ var-id)))))) + + #;None + (fail (Text/append "Indexed-type doesn't exist: " (->Text idx))))) + + _ + (fail "Wrong syntax for $"))) + +(def: #export (== left right) + {#;doc (doc "Tests whether the 2 values are identical (not just \"equal\")." + "This one should succeed:" + (let [value 5] + (== 5 5)) + + "This one should fail:" + (== 5 (+ 2 3)))} + (All [a] (-> a a Bool)) + (_lux_proc ["lux" "=="] [left right])) + +(macro: #export (^@ tokens) + {#;doc (doc "Allows you to simultaneously bind and de-structure a value." + (def: (hash (^@ set [a/Hash _])) + (List/fold (lambda [elem acc] (+ (:: a/Hash hash elem) acc)) + 0 + (->List set))))} + (case tokens + (^ (list& [_meta (#;FormS (list [_ (#;SymbolS ["" name])] pattern))] body branches)) + (let [g!whole (symbol$ ["" name])] + (return (list& g!whole + (` (case (~ g!whole) (~ pattern) (~ body))) + branches))) + + _ + (fail "Wrong syntax for ^@"))) + +(macro: #export (^|> tokens) + (case tokens + (^ (list& [_meta (#;FormS (list [_ (#;SymbolS ["" name])] [_ (#;TupleS steps)]))] body branches)) + (let [g!name (symbol$ ["" name])] + (return (list& g!name + (` (let [(~ g!name) (|> (~ g!name) (~@ steps))] + (~ body))) + branches))) + + _ + (fail "Wrong syntax for ^|>"))) + +(macro: #export (:!! tokens) + {#;doc (doc "Coerces the given expression to the type of whatever is expected." + (: Dinosaur (:!! (list 1 2 3))))} + (case tokens + (^ (list expr)) + (do Monad + [type get-expected-type] + (wrap (list (` (;_lux_:! (~ (type->ast type)) (~ expr)))))) + + _ + (fail "Wrong syntax for :!!"))) + +(def: #export (error! message) + {#;doc (doc "Causes an error, with the given error message." + (error! "OH NO!"))} + (-> Text Bottom) + (_lux_proc ["jvm" "throw"] [(_lux_proc ["jvm" "new:java.lang.Error:java.lang.String"] [message])])) + +(def: #hidden hack_Text/append + (-> Text Text Text) + Text/append) + +(def: get-cursor + (Lux Cursor) + (lambda [state] + (let [{#;info info #;source source #;modules modules #;scopes scopes + #;type-vars types #;host host #;seed seed + #;expected expected #;cursor cursor + #;scope-type-vars scope-type-vars} state] + (#;Right [state cursor])))) + +(macro: #export (with-cursor tokens) + {#;doc (doc "Given some text, appends to it a prefix for identifying where the text comes from." + "For example:" + (with-cursor (format "User: " user-id)) + "Would be the same as:" + (format "[the-module,the-line,the-column] " (format "User: " user-id)))} + (case tokens + (^ (list message)) + (do Monad + [cursor get-cursor] + (let [[module line column] cursor + cursor-prefix ($_ hack_Text/append "[" module "," (->Text line) "," (->Text column) "] ")] + (wrap (list (` (hack_Text/append (~ (text$ cursor-prefix)) (~ message))))))) + + _ + (fail "Wrong syntax for @"))) + +(macro: #export (undefined tokens) + {#;doc (doc "Meant to be used as a stand-in for functions with undefined implementations." + (def: (square x) + (-> Int Int) + (undefined)))} + (case tokens + #;Nil + (return (list (` (error! (with-cursor "Undefined behavior."))))) + + _ + (fail "Wrong syntax for undefined"))) + +(macro: #export (@pre tokens) + (case tokens + (^ (list test expr)) + (return (list (` (if (~ test) + (~ expr) + (error! (with-cursor (~ (text$ (Text/append "Pre-condition failed: " (ast-to-text test)))))))))) + + _ + (fail "Wrong syntax for @pre"))) + +(macro: #export (@post tokens) + (case tokens + (^ (list test pattern expr)) + (do Monad + [g!output (gensym "") + exp-type get-expected-type] + (wrap (list (` (let [(~ g!output) (: (~ (type->ast exp-type)) (~ expr)) + (~ pattern) (~ g!output)] + (if (~ test) + (~ g!output) + (error! (with-cursor (~ (text$ (Text/append "Post-condition failed: " (ast-to-text test)))))))))))) + + _ + (fail "Wrong syntax for @post"))) + +(do-template [ ] + [(def: #export ( input) + (-> ) + (_lux_proc [input]))] + + [int-to-nat ["int" "to-nat"] Int Nat] + [nat-to-int ["nat" "to-int"] Nat Int] + + [real-to-frac ["real" "to-frac"] Real Frac] + [frac-to-real ["frac" "to-real"] Frac Real] + ) + +(do-template [ ] + [(def: #export + (-> Nat Nat) + ( +1))] + + [inc+ ++] + [dec+ -+]) diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux new file mode 100644 index 000000000..d9039df13 --- /dev/null +++ b/stdlib/source/lux/cli.lux @@ -0,0 +1,271 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + [lux #- not] + (lux (control functor + applicative + monad) + (data (struct (list #as list #open ("List/" Monoid Monad))) + (text #as text #open ("Text/" Monoid)) + error + (sum #as sum)) + (codata [io]) + [compiler #+ with-gensyms Functor Monad] + (macro [ast] + ["s" syntax #+ syntax: Syntax]))) + +## [Types] +(type: #export (CLI a) + (-> (List Text) (Error [(List Text) a]))) + +## [Utils] +(def: (run' opt inputs) + (All [a] (-> (CLI a) (List Text) (Error [(List Text) a]))) + (opt inputs)) + +## [Structures] +(struct: #export _ (Functor CLI) + (def: (map f ma inputs) + (case (ma inputs) + (#;Left msg) (#;Left msg) + (#;Right [inputs' datum]) (#;Right [inputs' (f datum)])))) + +(struct: #export _ (Applicative CLI) + (def: functor Functor) + + (def: (wrap a inputs) + (#;Right [inputs a])) + + (def: (apply ff fa inputs) + (case (ff inputs) + (#;Right [inputs' f]) + (case (fa inputs') + (#;Right [inputs'' a]) + (#;Right [inputs'' (f a)]) + + (#;Left msg) + (#;Left msg)) + + (#;Left msg) + (#;Left msg)) + )) + +(struct: #export _ (Monad CLI) + (def: applicative Applicative) + + (def: (join mma inputs) + (case (mma inputs) + (#;Left msg) (#;Left msg) + (#;Right [inputs' ma]) (ma inputs')))) + +## [Combinators] +(def: #export any + {#;doc "Just returns the next input without applying any logic."} + (CLI Text) + (lambda [inputs] + (case inputs + (#;Cons arg inputs') + (#;Right [inputs' arg]) + + _ + (#;Left "Can't extract from empty arguments.")))) + +(def: #export (parse parser option) + {#;doc "Parses the next input with a parsing function."} + (All [a] (-> (-> Text (Error a)) (CLI Text) (CLI a))) + (lambda [inputs] + (case (option inputs) + (#;Right [inputs' input]) + (case (parser input) + (#;Right value) + (#;Right [inputs' value]) + + (#;Left parser-error) + (#;Left parser-error)) + + (#;Left option-error) + (#;Left option-error) + ))) + +(def: #export (option names) + {#;doc "Checks that a given option (with multiple possible names) has a value."} + (-> (List Text) (CLI Text)) + (lambda [inputs] + (let [[pre post] (list;split-with (. ;not (list;member? text;Eq names)) inputs)] + (case post + #;Nil + (#;Left ($_ Text/append "Missing option (" (text;join-with " " names) ")")) + + (^ (list& _ value post')) + (#;Right [(List/append pre post') value]) + + _ + (#;Left ($_ Text/append "Option lacks value (" (text;join-with " " names) ")")) + )))) + +(def: #export (flag names) + {#;doc "Checks that a given flag (with multiple possible names) is set."} + (-> (List Text) (CLI Bool)) + (lambda [inputs] + (let [[pre post] (list;split-with (. ;not (list;member? text;Eq names)) inputs)] + (case post + #;Nil + (#;Right [pre false]) + + (#;Cons _ post') + (#;Right [(List/append pre post') true]))))) + +(def: #export end + {#;doc "Ensures there are no more inputs."} + (CLI Unit) + (lambda [inputs] + (case inputs + #;Nil (#;Right [inputs []]) + _ (#;Left (Text/append "Unknown parameters: " (text;join-with " " inputs)))))) + +(def: #export (assert test message) + (-> Bool Text (CLI Unit)) + (lambda [inputs] + (if test + (#;Right [inputs []]) + (#;Left message)))) + +(def: #export (opt opt) + {#;doc "Optionality combinator."} + (All [a] + (-> (CLI a) (CLI (Maybe a)))) + (lambda [inputs] + (case (opt inputs) + (#;Left _) (#;Right [inputs #;None]) + (#;Right [inputs' x]) (#;Right [inputs' (#;Some x)])))) + +(def: #export (seq optL optR) + {#;doc "Sequencing combinator."} + (All [a b] (-> (CLI a) (CLI b) (CLI [a b]))) + (do Monad + [l optL + r optR] + (wrap [l r]))) + +(def: #export (alt optL optR) + {#;doc "Heterogeneous alternative combinator."} + (All [a b] (-> (CLI a) (CLI b) (CLI (| a b)))) + (lambda [inputs] + (case (optL inputs) + (#;Left msg) + (case (optR inputs) + (#;Left _) + (#;Left msg) + + (#;Right [inputs' r]) + (#;Right [inputs' (sum;right r)])) + + (#;Right [inputs' l]) + (#;Right [inputs' (sum;left l)])))) + +(def: #export (not opt) + (All [a] (-> (CLI a) (CLI Unit))) + (lambda [inputs] + (case (opt inputs) + (#;Left msg) + (#;Right [inputs []]) + + _ + (#;Left "Expected to fail; yet succeeded.")))) + +(def: #export (some opt) + {#;doc "0-or-more combinator."} + (All [a] + (-> (CLI a) (CLI (List a)))) + (lambda [inputs] + (case (opt inputs) + (#;Left _) (#;Right [inputs (list)]) + (#;Right [inputs' x]) (run' (do Monad + [xs (some opt)] + (wrap (list& x xs))) + inputs')))) + +(def: #export (many opt) + {#;doc "1-or-more combinator."} + (All [a] + (-> (CLI a) (CLI (List a)))) + (do Monad + [x opt + xs (some opt)] + (wrap (list& x xs)))) + +(def: #export (either pl pr) + {#;doc "Homogeneous alternative combinator."} + (All [a] + (-> (CLI a) (CLI a) (CLI a))) + (lambda [inputs] + (case (pl inputs) + (#;Left _) (pr inputs) + output output))) + +(def: #export (run opt inputs) + (All [a] (-> (CLI a) (List Text) (Error a))) + (case (opt inputs) + (#;Left msg) + (#;Left msg) + + (#;Right [_ value]) + (#;Right value))) + +## [Syntax] +(type: Program-Args + (#Raw-Program-Args Text) + (#Parsed-Program-Args (List [Text AST]))) + +(def: program-args^ + (Syntax Program-Args) + (s;alt s;local-symbol + (s;form (s;some (s;either (do s;Monad + [name s;local-symbol] + (wrap [name (` any)])) + (s;record (s;seq s;local-symbol s;any))))))) + +(syntax: #export (program: {args program-args^} body) + {#;doc (doc "Defines the entry-point to a program (similar to the \"main\" function/method in other programming languages)." + "Can take a list of all the input parameters to the program, or can destructure them using CLI-option combinators from the lux/cli module." + (program: all-args + (do Monad + [foo init-program + bar (do-something all-args)] + (wrap []))) + + (program: (name) + (io (log! (Text/append "Hello, " name)))) + + (program: ([config config^]) + (do Monad + [data (init-program config)] + (do-something data))))} + (case args + (#Raw-Program-Args args) + (wrap (list (` (;_lux_program (~ (ast;symbol ["" args])) + (~ body))))) + + (#Parsed-Program-Args args) + (with-gensyms [g!args g!_ g!output g!message] + (wrap (list (` (;_lux_program (~ g!args) + (case ((: (CLI (io;IO Unit)) + (do Monad + [(~@ (|> args + (List/map (lambda [[name parser]] + (list (ast;symbol ["" name]) parser))) + List/join)) + (~ g!_) end] + ((~' wrap) (~ body)))) + (~ g!args)) + (#;Right [(~ g!_) (~ g!output)]) + (~ g!output) + + (#;Left (~ g!message)) + (error! (~ g!message)) + ))) + ))) + )) diff --git a/stdlib/source/lux/codata/cont.lux b/stdlib/source/lux/codata/cont.lux new file mode 100644 index 000000000..b851d417c --- /dev/null +++ b/stdlib/source/lux/codata/cont.lux @@ -0,0 +1,64 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (macro (ast #as ast)) + (control (functor #as F #refer #all) + (applicative #as A #refer #all) + (monad #as M #refer #all)) + (data (struct list))) + (.. function)) + +## [Types] +(type: #export (Cont a) + (All [b] + (-> (-> a b) b))) + +## [Syntax] +(macro: #export (@lazy tokens state) + {#;doc (doc "Delays the evaluation of an expression, by wrapping it in a continuation 'thunk'." + (@lazy (some-computation some-input)))} + (case tokens + (^ (list value)) + (let [blank (ast;symbol ["" ""])] + (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) + + _ + (#;Left "Wrong syntax for @lazy"))) + +## [Functions] +(def: #export (call/cc f) + {#;doc "Call with current continuation."} + (All [a b c] (Cont (-> a (Cont b c)) (Cont a c))) + (lambda [k] + (f (lambda [a _] + (k a)) + k))) + +(def: #export (run thunk) + {#;doc "Forces a continuation thunk to be evaluated."} + (All [a] + (-> (Cont a) a)) + (thunk id)) + +## [Structs] +(struct: #export _ (Functor Cont) + (def: (map f ma) + (lambda [k] (ma (. k f))))) + +(struct: #export _ (Applicative Cont) + (def: functor Functor) + + (def: (wrap a) + (@lazy a)) + + (def: (apply ff fa) + (@lazy ((run ff) (run fa))))) + +(struct: #export _ (Monad Cont) + (def: applicative Applicative) + + (def: join run)) diff --git a/stdlib/source/lux/codata/env.lux b/stdlib/source/lux/codata/env.lux new file mode 100644 index 000000000..8883b4a66 --- /dev/null +++ b/stdlib/source/lux/codata/env.lux @@ -0,0 +1,65 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + ["M" monad #*]))) + +## [Types] +(type: #export (Env r a) + (-> r a)) + +## [Structures] +(struct: #export Functor (All [r] (Functor (Env r))) + (def: (map f fa) + (lambda [env] + (f (fa env))))) + +(struct: #export Applicative (All [r] (Applicative (Env r))) + (def: functor Functor) + + (def: (wrap x) + (lambda [env] x)) + + (def: (apply ff fa) + (lambda [env] + ((ff env) (fa env))))) + +(struct: #export Monad (All [r] (Monad (Env r))) + (def: applicative Applicative) + + (def: (join mma) + (lambda [env] + (mma env env)))) + +## [Values] +(def: #export ask + {#;doc "Get the value of the environment."} + (All [r] (Env r r)) + (lambda [env] env)) + +(def: #export (local change env-proc) + {#;doc "Run computation with a locally-modified environment."} + (All [r a] (-> (-> r r) (Env r a) (Env r a))) + (|>. change env-proc)) + +(def: #export (run env env-proc) + (All [r a] (-> r (Env r a) a)) + (env-proc env)) + +(struct: #export (EnvT Monad) + (All [M e] (-> (Monad M) (Monad (All [a] (Env e (M a)))))) + (def: applicative (compA Applicative (get@ #M;applicative Monad))) + (def: (join eMeMa) + (lambda [env] + (do Monad + [eMa (run env eMeMa)] + (run env eMa))))) + +(def: #export lift-env + (All [M e a] (-> (M a) (Env e (M a)))) + (:: Monad wrap)) diff --git a/stdlib/source/lux/codata/function.lux b/stdlib/source/lux/codata/function.lux new file mode 100644 index 000000000..fba5528a8 --- /dev/null +++ b/stdlib/source/lux/codata/function.lux @@ -0,0 +1,23 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monoid))) + +## [Functions] +(def: #export (const x y) + (All [a b] (-> a (-> b a))) + x) + +(def: #export (flip f) + (All [a b c] + (-> (-> a b c) (-> b a c))) + (lambda [x y] (f y x))) + +## [Structures] +(struct: #export Monoid (Monoid (All [a] (-> a a))) + (def: unit id) + (def: append .)) diff --git a/stdlib/source/lux/codata/io.lux b/stdlib/source/lux/codata/io.lux new file mode 100644 index 000000000..1398dfae5 --- /dev/null +++ b/stdlib/source/lux/codata/io.lux @@ -0,0 +1,56 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + monad) + (data (struct list)))) + +## [Types] +(type: #export (IO a) + (-> Void a)) + +## [Syntax] +(macro: #export (io tokens state) + {#;doc (doc + "Delays the evaluation of an expression, by wrapping it in an IO 'thunk'." + "Great for wrapping side-effecting computations (which won't be performed until the IO is \"run\")." + (io (exec + (log! msg) + "Some value...")))} + (case tokens + (^ (list value)) + (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])] + (#;Right [state (list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) + + _ + (#;Left "Wrong syntax for io"))) + +## [Structures] +(struct: #export _ (Functor IO) + (def: (map f ma) + (io (f (ma (:! Void [])))))) + +(struct: #export _ (Applicative IO) + (def: functor Functor) + + (def: (wrap x) + (io x)) + + (def: (apply ff fa) + (io ((ff (:! Void [])) (fa (:! Void [])))))) + +(struct: #export _ (Monad IO) + (def: applicative Applicative) + + (def: (join mma) + (io ((mma (:! Void [])) (:! Void []))))) + +## [Functions] +(def: #export (run action) + (All [a] (-> (IO a) a)) + (action (:! Void []))) diff --git a/stdlib/source/lux/codata/state.lux b/stdlib/source/lux/codata/state.lux new file mode 100644 index 000000000..82e9b40fd --- /dev/null +++ b/stdlib/source/lux/codata/state.lux @@ -0,0 +1,114 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + ["A" applicative #*] + ["M" monad #*]))) + +## [Types] +(type: #export (State s a) + (-> s [s a])) + +## [Structures] +(struct: #export Functor (All [s] (Functor (State s))) + (def: (map f ma) + (lambda [state] + (let [[state' a] (ma state)] + [state' (f a)])))) + +(struct: #export Applicative (All [s] (Applicative (State s))) + (def: functor Functor) + + (def: (wrap a) + (lambda [state] + [state a])) + + (def: (apply ff fa) + (lambda [state] + (let [[state' f] (ff state) + [state'' a] (fa state')] + [state'' (f a)])))) + +(struct: #export Monad (All [s] (Monad (State s))) + (def: applicative Applicative) + + (def: (join mma) + (lambda [state] + (let [[state' ma] (mma state)] + (ma state'))))) + +## [Values] +(def: #export get + (All [s] (State s s)) + (lambda [state] + [state state])) + +(def: #export (put new-state) + (All [s] (-> s (State s Unit))) + (lambda [state] + [new-state []])) + +(def: #export (update change) + (All [s] (-> (-> s s) (State s Unit))) + (lambda [state] + [(change state) []])) + +(def: #export (use user) + {#;doc "Run function on current state."} + (All [s a] (-> (-> s a) (State s a))) + (lambda [state] + [state (user state)])) + +(def: #export (local change action) + {#;doc "Run computation with a locally-modified state."} + (All [s a] (-> (-> s s) (State s a) (State s a))) + (lambda [state] + (let [[state' output] (action (change state))] + [state output]))) + +(def: #export (run state action) + (All [s a] (-> s (State s a) [s a])) + (action state)) + +(struct: (Functor Functor) + (All [M s] (-> (Functor M) (Functor (All [a] (-> s (M [s a])))))) + (def: (map f sfa) + (lambda [state] + (:: Functor map (lambda [[s a]] [s (f a)]) + (sfa state))))) + +(struct: (Applicative Monad) + (All [M s] (-> (Monad M) (Applicative (All [a] (-> s (M [s a])))))) + (def: functor (Functor (get@ [#M;applicative #A;functor] + Monad))) + + (def: (wrap a) + (lambda [state] + (:: Monad wrap [state a]))) + + (def: (apply sFf sFa) + (lambda [state] + (do Monad + [[state f] (sFf state) + [state a] (sFa state)] + (wrap [state (f a)]))))) + +(struct: #export (StateT Monad) + (All [M s] (-> (Monad M) (Monad (All [a] (-> s (M [s a])))))) + (def: applicative (Applicative Monad)) + (def: (join sMsMa) + (lambda [state] + (do Monad + [[state' sMa] (sMsMa state)] + (sMa state'))))) + +(def: #export (lift-state Monad ma) + (All [M s a] (-> (Monad M) (M a) (-> s (M [s a])))) + (lambda [state] + (do Monad + [a ma] + (wrap [state a])))) diff --git a/stdlib/source/lux/codata/struct/stream.lux b/stdlib/source/lux/codata/struct/stream.lux new file mode 100644 index 000000000..8814ec460 --- /dev/null +++ b/stdlib/source/lux/codata/struct/stream.lux @@ -0,0 +1,135 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + monad + comonad) + [compiler #+ with-gensyms] + (macro ["s" syntax #+ syntax: Syntax]) + (data (struct [list "List/" Monad]) + bool) + (codata [cont #+ @lazy Cont]))) + +## [Types] +(type: #export (Stream a) + (Cont [a (Stream a)])) + +## [Utils] +(def: (cycle' x xs init full) + (All [a] + (-> a (List a) a (List a) (Stream a))) + (case xs + #;Nil (@lazy [x (cycle' init full init full)]) + (#;Cons x' xs') (@lazy [x (cycle' x' xs' init full)]))) + +## [Functions] +(def: #export (iterate f x) + (All [a] + (-> (-> a a) a (Stream a))) + (@lazy [x (iterate f (f x))])) + +(def: #export (repeat x) + (All [a] + (-> a (Stream a))) + (@lazy [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 [ ] + [(def: #export ( s) + (All [a] (-> (Stream a) )) + (let [[h t] (cont;run s)] + ))] + + [head a h] + [tail (Stream a) t]) + +(def: #export (at idx s) + (All [a] (-> Nat (Stream a) a)) + (let [[h t] (cont;run s)] + (if (>+ +0 idx) + (at (dec+ idx) t) + h))) + +(do-template [ ] + [(def: #export ( pred xs) + (All [a] + (-> (Stream a) (List a))) + (let [[x xs'] (cont;run xs)] + (if + (list& x ( xs')) + (list)))) + + (def: #export ( pred xs) + (All [a] + (-> (Stream a) (Stream a))) + (let [[x xs'] (cont;run xs)] + (if + ( xs') + xs))) + + (def: #export ( pred xs) + (All [a] + (-> (Stream a) [(List a) (Stream a)])) + (let [[x xs'] (cont;run xs)] + (if + (let [[tail next] ( xs')] + [(#;Cons [x tail]) next]) + [(list) xs])))] + + [take-while drop-while split-with (-> a Bool) (pred x) pred] + [take drop split Nat (>+ +0 pred) (dec+ pred)] + ) + +(def: #export (unfold step init) + (All [a b] + (-> (-> a [a b]) a (Stream b))) + (let [[next x] (step init)] + (@lazy [x (unfold step next)]))) + +(def: #export (filter p xs) + (All [a] (-> (-> a Bool) (Stream a) (Stream a))) + (let [[x xs'] (cont;run xs)] + (if (p x) + (@lazy [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] +(struct: #export _ (Functor Stream) + (def: (map f fa) + (let [[h t] (cont;run fa)] + (@lazy [(f h) (map f t)])))) + +(struct: #export _ (CoMonad Stream) + (def: functor Functor) + (def: unwrap head) + (def: (split wa) + (let [[head tail] (cont;run wa)] + (@lazy [wa (split tail)])))) + +## [Pattern-matching] +(syntax: #export (^stream& {patterns (s;form (s;many s;any))} body {branches (s;some s;any)}) + {#;doc (doc "Allows destructuring of streams in pattern-matching expressions." + "Caveat emptor: Only use it for destructuring, and not for testing values within the streams." + (let [(^stream& x y z _tail) (some-stream-func 1 2 3)] + (func x y z)))} + (with-gensyms [g!s] + (let [body+ (` (let [(~@ (List/join (List/map (lambda [pattern] + (list (` [(~ pattern) (~ g!s)]) + (` (cont;run (~ g!s))))) + patterns)))] + (~ body)))] + (wrap (list& g!s body+ branches))))) diff --git a/stdlib/source/lux/compiler.lux b/stdlib/source/lux/compiler.lux new file mode 100644 index 000000000..d7b072a56 --- /dev/null +++ b/stdlib/source/lux/compiler.lux @@ -0,0 +1,559 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: {#;doc "Functions for extracting information from the state of the compiler."} + lux + (lux (macro [ast]) + (control functor + applicative + monad) + (data (struct [list #* "List/" Monoid Monad]) + [number] + [text "Text/" Monoid Eq] + [product] + [ident "Ident/" Codec] + maybe + error))) + +## (type: (Lux a) +## (-> Compiler (Error [Compiler a]))) + +(struct: #export _ (Functor Lux) + (def: (map f fa) + (lambda [state] + (case (fa state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' a]) + (#;Right [state' (f a)]))))) + +(struct: #export _ (Applicative Lux) + (def: functor Functor) + + (def: (wrap x) + (lambda [state] + (#;Right [state x]))) + + (def: (apply ff fa) + (lambda [state] + (case (ff state) + (#;Right [state' f]) + (case (fa state') + (#;Right [state'' a]) + (#;Right [state'' (f a)]) + + (#;Left msg) + (#;Left msg)) + + (#;Left msg) + (#;Left msg))))) + +(struct: #export _ (Monad Lux) + (def: applicative Applicative) + + (def: (join mma) + (lambda [state] + (case (mma state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' ma]) + (ma state'))))) + +(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: #export (run' compiler action) + (All [a] (-> Compiler (Lux a) (Error [Compiler a]))) + (action compiler)) + +(def: #export (run compiler action) + (All [a] (-> Compiler (Lux a) (Error a))) + (case (action compiler) + (#;Left error) + (#;Left error) + + (#;Right [_ output]) + (#;Right output))) + +(def: #export (either left right) + (All [a] (-> (Lux a) (Lux a) (Lux a))) + (lambda [compiler] + (case (left compiler) + (#;Left error) + (right compiler) + + (#;Right [compiler' output]) + (#;Right [compiler' output])))) + +(def: #export (assert test message) + (-> Bool Text (Lux Unit)) + (lambda [compiler] + (if test + (#;Right [compiler []]) + (#;Left message)))) + +(def: #export (fail msg) + (All [a] + (-> Text (Lux a))) + (lambda [_] + (#;Left msg))) + +(def: #export (find-module name) + (-> Text (Lux Module)) + (lambda [state] + (case (get name (get@ #;modules state)) + (#;Some module) + (#;Right [state module]) + + _ + (#;Left ($_ Text/append "Unknown module: " name))))) + +(def: #export current-module-name + (Lux Text) + (lambda [state] + (case (list;last (get@ #;scopes state)) + (#;Some scope) + (case (get@ #;name scope) + (#;Cons m-name #;Nil) + (#;Right [state m-name]) + + _ + (#;Left "Improper name for scope.")) + + _ + (#;Left "Empty environment!") + ))) + +(def: #export current-module + (Lux Module) + (do Monad + [this-module-name current-module-name] + (find-module this-module-name))) + +(def: #export (get-ann tag meta) + (-> Ident Anns (Maybe Ann-Value)) + (let [[p n] tag] + (case meta + (#;Cons [[p' n'] dmv] meta') + (if (and (Text/= p p') + (Text/= n n')) + (#;Some dmv) + (get-ann tag meta')) + + #;Nil + #;None))) + +(do-template [ ] + [(def: #export ( tag meta) + (-> Ident Anns (Maybe )) + (case (get-ann tag meta) + (#;Some ( value)) + (#;Some value) + + _ + #;None))] + + [get-bool-ann #;BoolM Bool] + [get-int-ann #;IntM Int] + [get-real-ann #;RealM Real] + [get-char-ann #;CharM Char] + [get-text-ann #;TextM Text] + [get-ident-ann #;IdentM Ident] + [get-list-ann #;ListM (List Ann-Value)] + [get-dict-ann #;DictM (List [Text Ann-Value])] + ) + +(def: #export (get-doc meta) + (-> Anns (Maybe Text)) + (get-text-ann ["lux" "doc"] meta)) + +(def: #export (flag-set? flag-name meta) + (-> Ident Anns Bool) + (case (get-ann flag-name meta) + (#;Some (#;BoolM true)) + true + + _ + false)) + +(do-template [ ] + [(def: #export + (-> Anns Bool) + (flag-set? (ident-for )))] + + [export? #;export?] + [hidden? #;hidden?] + [macro? #;macro?] + [type? #;type?] + [struct? #;struct?] + [type-rec? #;type-rec?] + [sig? #;sig?] + ) + +(do-template [ ] + [(def: ( dmv) + (-> Ann-Value (Maybe )) + (case dmv + ( actual-value) + (#;Some actual-value) + + _ + #;None))] + + [try-mlist #;ListM (List Ann-Value)] + [try-mtext #;TextM Text] + ) + +(do-template [ ] + [(def: #export ( meta) + (-> Anns (List Text)) + (default (list) + (do Monad + [_args (get-ann (ident-for ) meta) + args (try-mlist _args)] + (mapM @ try-mtext args))))] + + [func-args #;func-args] + [type-args #;type-args] + ) + +(def: (find-macro' modules this-module module name) + (-> (List [Text Module]) Text Text Text + (Maybe Macro)) + (do Monad + [$module (get module modules) + [def-type def-anns def-value] (: (Maybe Def) (|> (: Module $module) (get@ #;defs) (get name)))] + (if (and (macro? def-anns) + (or (export? def-anns) (Text/= module this-module))) + (#;Some (:! Macro def-value)) + (case (get-ann ["lux" "alias"] def-anns) + (#;Some (#;IdentM [r-module r-name])) + (find-macro' modules this-module r-module r-name) + + _ + #;None)))) + +(def: #export (find-macro ident) + (-> Ident (Lux (Maybe Macro))) + (do Monad + [this-module current-module-name] + (let [[module name] ident] + (: (Lux (Maybe Macro)) + (lambda [state] + (#;Right [state (find-macro' (get@ #;modules state) this-module module name)])))))) + +(def: #export (normalize ident) + (-> Ident (Lux Ident)) + (case ident + ["" name] + (do Monad + [module-name current-module-name] + (wrap [module-name name])) + + _ + (:: Monad wrap ident))) + +(def: #export (macro-expand-once syntax) + (-> AST (Lux (List AST))) + (case syntax + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] + (do Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (macro args) + + #;None + (:: Monad wrap (list syntax)))) + + _ + (:: Monad wrap (list syntax)))) + +(def: #export (macro-expand syntax) + (-> AST (Lux (List AST))) + (case syntax + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] + (do Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (do Monad + [expansion (macro args) + expansion' (mapM Monad macro-expand expansion)] + (wrap (:: Monad join expansion'))) + + #;None + (:: Monad wrap (list syntax)))) + + _ + (:: Monad wrap (list syntax)))) + +(def: #export (macro-expand-all syntax) + (-> AST (Lux (List AST))) + (case syntax + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] + (do Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (do Monad + [expansion (macro args) + expansion' (mapM Monad macro-expand-all expansion)] + (wrap (:: Monad join expansion'))) + + #;None + (do Monad + [parts' (mapM Monad macro-expand-all (list& (ast;symbol macro-name) args))] + (wrap (list (ast;form (:: Monad join parts'))))))) + + [_ (#;FormS (#;Cons [harg targs]))] + (do Monad + [harg+ (macro-expand-all harg) + targs+ (mapM Monad macro-expand-all targs)] + (wrap (list (ast;form (List/append harg+ (:: Monad join (: (List (List AST)) targs+))))))) + + [_ (#;TupleS members)] + (do Monad + [members' (mapM Monad macro-expand-all members)] + (wrap (list (ast;tuple (:: Monad join members'))))) + + _ + (:: Monad wrap (list syntax)))) + +(def: #export (gensym prefix) + (-> Text (Lux AST)) + (lambda [state] + (#;Right [(update@ #;seed inc+ state) + (ast;symbol ["" ($_ Text/append "__gensym__" prefix (:: number;Codec encode (get@ #;seed state)))])]))) + +(def: (get-local-symbol ast) + (-> AST (Lux Text)) + (case ast + [_ (#;SymbolS [_ name])] + (:: Monad wrap name) + + _ + (fail (Text/append "AST is not a local symbol: " (ast;ast-to-text ast))))) + +(macro: #export (with-gensyms tokens) + {#;doc (doc "Creates new symbols and offers them to the body expression." + (syntax: #export (synchronized lock body) + (with-gensyms [g!lock g!body g!_] + (wrap (list (` (let [(~ g!lock) (~ lock) + (~ g!_) (;_jvm_monitorenter (~ g!lock)) + (~ g!body) (~ body) + (~ g!_) (;_jvm_monitorexit (~ g!lock))] + (~ g!body))))) + )))} + (case tokens + (^ (list [_ (#;TupleS symbols)] body)) + (do Monad + [symbol-names (mapM @ get-local-symbol symbols) + #let [symbol-defs (List/join (List/map (: (-> Text (List AST)) + (lambda [name] (list (ast;symbol ["" name]) (` (gensym (~ (ast;text name))))))) + symbol-names))]] + (wrap (list (` (do Monad + [(~@ symbol-defs)] + (~ body)))))) + + _ + (fail "Wrong syntax for with-gensyms"))) + +(def: #export (macro-expand-1 token) + (-> AST (Lux AST)) + (do Monad + [token+ (macro-expand token)] + (case token+ + (^ (list token')) + (wrap token') + + _ + (fail "Macro expanded to more than 1 element.")))) + +(def: #export (module-exists? module) + (-> Text (Lux Bool)) + (lambda [state] + (#;Right [state (case (get module (get@ #;modules state)) + (#;Some _) + true + + #;None + false)]))) + +(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: #export (find-var-type name) + (-> Text (Lux Type)) + (lambda [state] + (let [test (: (-> [Text Analysis] Bool) + (|>. product;left (Text/= name)))] + (case (do Monad + [scope (find (lambda [env] + (or (any? test (get@ [#;locals #;mappings] env)) + (any? test (get@ [#;closure #;mappings] env)))) + (get@ #;scopes state)) + [_ [[type _] _]] (try-both (find test) + (get@ [#;locals #;mappings] scope) + (get@ [#;closure #;mappings] scope))] + (wrap type)) + (#;Some var-type) + (#;Right [state var-type]) + + #;None + (#;Left ($_ Text/append "Unknown variable: " name)))))) + +(def: #export (find-def name) + (-> Ident (Lux Def)) + (lambda [state] + (case (: (Maybe Def) + (do Monad + [#let [[v-prefix v-name] name] + (^slots [#;defs]) (get v-prefix (get@ #;modules state))] + (get v-name defs))) + (#;Some _meta) + (#;Right [state _meta]) + + _ + (#;Left ($_ Text/append "Unknown definition: " (Ident/encode name)))))) + +(def: #export (find-def-type name) + (-> Ident (Lux Type)) + (do Monad + [[def-type def-data def-value] (find-def name)] + (wrap def-type))) + +(def: #export (find-type name) + (-> Ident (Lux Type)) + (do Monad + [#let [[_ _name] name]] + (either (find-var-type _name) + (do @ + [name (normalize name)] + (find-def-type name))))) + +(def: #export (find-type-def name) + (-> Ident (Lux Type)) + (do Monad + [[def-type def-data def-value] (find-def name)] + (wrap (:! Type def-value)))) + +(def: #export (defs module-name) + (-> Text (Lux (List [Text Def]))) + (lambda [state] + (case (get module-name (get@ #;modules state)) + #;None (#;Left ($_ Text/append "Unknown module: " module-name)) + (#;Some module) (#;Right [state (get@ #;defs module)]) + ))) + +(def: #export (exports module-name) + (-> Text (Lux (List [Text Def]))) + (do Monad + [defs (defs module-name)] + (wrap (filter (lambda [[name [def-type def-anns def-value]]] + (and (export? def-anns) + (not (hidden? def-anns)))) + defs)))) + +(def: #export modules + (Lux (List Text)) + (lambda [state] + (|> state + (get@ #;modules) + (List/map product;left) + [state] + #;Right))) + +(def: #export (tags-of type-name) + (-> Ident (Lux (List Ident))) + (do Monad + [#let [[module name] type-name] + module (find-module module)] + (case (get name (get@ #;types module)) + (#;Some [tags _]) + (wrap tags) + + _ + (wrap (list))))) + +(def: #export cursor + (Lux Cursor) + (lambda [state] + (#;Right [state (get@ #;cursor state)]))) + +(def: #export expected-type + (Lux Type) + (lambda [state] + (case (get@ #;expected state) + (#;Some type) + (#;Right [state type]) + + #;None + (#;Left "Not expecting any type.")))) + +(def: #export (imported-modules module-name) + (-> Text (Lux (List Text))) + (do Monad + [(^slots [#;imports]) (find-module module-name)] + (wrap imports))) + +(def: #export (resolve-tag (^@ tag [module name])) + (-> Ident (Lux [Nat (List Ident) Type])) + (do Monad + [=module (find-module module) + this-module-name current-module-name] + (case (get name (get@ #;tags =module)) + (#;Some [idx tag-list exported? type]) + (if (or exported? + (Text/= this-module-name module)) + (wrap [idx tag-list type]) + (fail ($_ Text/append "Can't access tag: " (Ident/encode tag) " from module " this-module-name))) + + _ + (fail ($_ Text/append "Unknown tag: " (Ident/encode tag)))))) + +(def: #export locals + (Lux (List (List [Text Type]))) + (lambda [state] + (case (list;inits (get@ #;scopes state)) + #;None + (#;Left "No local environment") + + (#;Some scopes) + (#;Right [state + (List/map (|>. (get@ [#;locals #;mappings]) + (List/map (lambda [[name [[type cursor] analysis]]] + [name type]))) + scopes)])))) + +(def: #export (un-alias def-name) + (-> Ident (Lux Ident)) + (do Monad + [def-name (normalize def-name) + [_ def-anns _] (find-def def-name)] + (case (get-ann (ident-for #;alias) def-anns) + (#;Some (#;IdentM real-def-name)) + (wrap real-def-name) + + _ + (wrap def-name)))) diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux new file mode 100644 index 000000000..1eb3cee21 --- /dev/null +++ b/stdlib/source/lux/concurrency/actor.lux @@ -0,0 +1,278 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad) + (codata [io #- run] + function) + (data error + text/format + (struct [list "List/" Monoid Monad]) + [product] + [number "Nat/" Codec]) + [compiler #+ with-gensyms] + (macro [ast] + ["s" syntax #+ syntax: Syntax] + (syntax [common])) + [type]) + (.. [promise #+ Monad] + [stm #+ Monad] + [frp])) + +## [Types] +(type: #export (Actor s m) + {#mailbox (stm;Var m) + #kill-signal (promise;Promise Unit) + #obituary (promise;Promise [(Maybe Text) s (List m)])}) + +(type: #export (Proc s m) + {#step (-> (Actor s m) (-> m s (promise;Promise (Error s)))) + #end (-> (Maybe Text) s (promise;Promise Unit))}) + +## [Values] +(def: #export (spawn init [proc on-death]) + {#;doc "Given a procedure and initial state, launches an actor and returns it."} + (All [s m] (-> s (Proc s m) (IO (Actor s m)))) + (io (let [mailbox (stm;var (:! ($ 1) [])) + kill-signal (promise;promise Unit) + obituary (promise;promise [(Maybe Text) ($ 0) (List ($ 1))]) + self {#mailbox mailbox + #kill-signal kill-signal + #obituary obituary} + mailbox-chan (io;run (stm;follow "\tmailbox\t" mailbox)) + proc (proc self) + |mailbox| (stm;var mailbox-chan) + _ (:: Monad map + (lambda [_] + (io;run (do Monad + [mb (stm;read! |mailbox|)] + (frp;close mb)))) + kill-signal) + process (loop [state init + messages mailbox-chan] + (do Monad + [?messages+ messages] + (case ?messages+ + ## No kill-signal so far, so I may proceed... + (#;Some [message messages']) + (do Monad + [#let [_ (io;run (stm;write! messages' |mailbox|))] + ?state' (proc message state)] + (case ?state' + (#;Left error) + (do @ + [#let [_ (io;run (promise;resolve [] kill-signal)) + _ (io;run (frp;close messages')) + death-message (#;Some error)] + _ (on-death death-message state) + remaining-messages (frp;consume messages')] + (wrap [death-message state (#;Cons message remaining-messages)])) + + (#;Right state') + (recur state' messages'))) + + ## Otherwise, clean-up and return current state. + #;None + (do Monad + [#let [_ (io;run (frp;close messages)) + death-message #;None] + _ (on-death death-message state)] + (wrap [death-message state (list)])))))] + self))) + +(def: #export poison + {#;doc "Immediately kills the given actor (if it's not already dead)."} + (All [s m] (-> (Actor s m) (io;IO Bool))) + (|>. (get@ #kill-signal) (promise;resolve []))) + +(def: #export (alive? actor) + (All [s m] (-> (Actor s m) Bool)) + (case [(promise;poll (get@ #kill-signal actor)) + (promise;poll (get@ #obituary actor))] + [#;None #;None] + true + + _ + false)) + +(def: #export (send message actor) + (All [s m] (-> m (Actor s m) (promise;Promise Bool))) + (if (alive? actor) + (exec (io;run (stm;write! message (get@ #mailbox actor))) + (:: Monad wrap true)) + (:: Monad wrap false))) + +(def: #export (keep-alive init proc) + {#;doc "Given initial-state and a procedure, launches and actor that will reboot if it dies of errors. + However, it can still be killed."} + (All [s m] (-> s (Proc s m) (IO (Actor s m)))) + (io (let [ka-actor (: (Actor (Actor ($ 0) ($ 1)) ($ 1)) + (io;run (spawn (io;run (spawn init proc)) + {#step (lambda [*self* message server] + (do Monad + [was-sent? (send message server)] + (if was-sent? + (wrap (#;Right server)) + (do @ + [[?cause state unprocessed-messages] (get@ #obituary server)] + (exec (log! (format "ACTOR DIED:\n" (default "" ?cause) "\n RESTARTING")) + (do @ + [#let [new-server (io;run (spawn state proc)) + mailbox (get@ #mailbox new-server)] + _ (promise;future (mapM io;Monad ((flip stm;write!) mailbox) (#;Cons message unprocessed-messages)))] + (wrap (#;Right new-server)))) + )))) + #end (lambda [_ server] (exec (io;run (poison server)) + (:: Monad wrap [])))})))] + (update@ #obituary (: (-> (promise;Promise [(Maybe Text) (Actor ($ 0) ($ 1)) (List ($ 1))]) + (promise;Promise [(Maybe Text) ($ 0) (List ($ 1))])) + (lambda [process] + (do Monad + [[_ server unprocessed-messages-0] process + [cause state unprocessed-messages-1] (get@ #obituary server)] + (wrap [cause state (List/append unprocessed-messages-0 unprocessed-messages-1)])))) + ka-actor)))) + +## [Syntax] +(type: Method + {#name Text + #vars (List Text) + #args (List [Text AST]) + #return AST + #body AST}) + +(def: method^ + (Syntax Method) + (s;form (do s;Monad + [_ (s;symbol! ["" "method:"]) + vars (s;default (list) (s;tuple (s;some s;local-symbol))) + [name args] (s;form ($_ s;seq + s;local-symbol + (s;many common;typed-arg) + )) + return s;any + body s;any] + (wrap {#name name + #vars vars + #args args + #return return + #body body})))) + +(def: stop^ + (Syntax AST) + (s;form (do s;Monad + [_ (s;symbol! ["" "stop:"])] + s;any))) + +(def: actor-decl^ + (Syntax [(List Text) Text (List [Text AST])]) + (s;seq (s;default (list) (s;tuple (s;some s;local-symbol))) + (s;either (s;form (s;seq s;local-symbol (s;many common;typed-arg))) + (s;seq s;local-symbol (:: s;Monad wrap (list)))))) + +(def: (actor-def-decl [_vars _name _args] return-type) + (-> [(List Text) Text (List [Text AST])] AST (List AST)) + (let [decl (` ((~ (ast;symbol ["" (format _name "//new")])) (~@ (List/map (|>. product;left [""] ast;symbol) _args)))) + base-type (` (-> (~@ (List/map product;right _args)) + (~ return-type))) + type (case _vars + #;Nil + base-type + + _ + (` (All [(~@ (List/map (|>. [""] ast;symbol) _vars))] + (~ base-type))))] + (list decl + type))) + +(syntax: #export (actor: {_ex-lev common;export-level} + {(^@ decl [_vars _name _args]) actor-decl^} + state-type + {methods (s;many method^)} + {?stop (s;opt stop^)}) + {#;doc (doc "Allows defining an actor, with a set of methods that can be called on it." + "The methods can return promisehronous outputs." + "The methods can access the actor's state through the *state* variable." + "The methods can also access the actor itself through the *self* variable." + + (actor: #export Adder + Int + + (method: (count! {to-add Int}) + [Int Int] + (if (>= 0 to-add) + (do Monad + [#let [new-state (+ to-add *state*)]] + (wrap (#;Right [new-state [*state* new-state]]))) + (do Monad + [] + (wrap (#;Left "Can't add negative numbers!"))))) + ))} + (with-gensyms [g!message g!error g!return g!error g!output] + (let [g!state-name (ast;symbol ["" (format _name "//STATE")]) + g!protocol-name (ast;symbol ["" (format _name "//PROTOCOL")]) + g!self (ast;symbol ["" "*self*"]) + g!state (ast;symbol ["" "*state*"]) + g!cause (ast;symbol ["" "*cause*"]) + g!stop-body (default (` (:: promise;Monad (~' wrap) [])) ?stop) + protocol (List/map (lambda [(^slots [#name #vars #args #return #body])] + (` ((~ (ast;tag ["" name])) [(~@ (List/map product;right args))] (promise;Promise (~ return))))) + methods) + protocol-pm (List/map (: (-> Method [AST AST]) + (lambda [(^slots [#name #vars #args #return #body])] + (let [arg-names (|> (list;size args) (list;range+ +1) (List/map (|>. Nat/encode [""] ast;symbol))) + body-func (` (: (-> (~ g!state-name) (~@ (List/map product;right args)) (promise;Promise (Error [(~ g!state-name) (~ return)]))) + (lambda (~ (ast;symbol ["" _name])) [(~ g!state) (~@ (List/map (|>. product;left [""] ast;symbol) args))] + (do promise;Monad + [] + (~ body)))))] + [(` [[(~@ arg-names)] (~ g!return)]) + (` (do promise;Monad + [(~ g!output) ((~ body-func) (~ g!state) (~@ arg-names))] + (case (~ g!output) + (#;Right [(~ g!state) (~ g!output)]) + (exec (io;run (promise;resolve (~ g!output) (~ g!return))) + ((~' wrap) (#;Right (~ g!state)))) + + (#;Left (~ g!error)) + ((~' wrap) (#;Left (~ g!error)))) + ))]))) + methods) + g!proc (` {#step (lambda [(~ g!self) (~ g!message) (~ g!state)] + (case (~ g!message) + (~@ (if (=+ +1 (list;size protocol-pm)) + (List/join (List/map (lambda [[pattern clause]] + (list pattern clause)) + protocol-pm)) + (List/join (List/map (lambda [[method [pattern clause]]] + (list (` ((~ (ast;tag ["" (get@ #name method)])) (~ pattern))) + clause)) + (list;zip2 methods protocol-pm))))) + )) + #end (lambda [(~ g!cause) (~ g!state)] + (do promise;Monad + [] + (~ g!stop-body)))}) + g!actor-name (ast;symbol ["" _name]) + g!methods (List/map (: (-> Method AST) + (lambda [(^slots [#name #vars #args #return #body])] + (let [arg-names (|> (list;size args) (list;range+ +1) (List/map (|>. Nat/encode [""] ast;symbol))) + type (` (-> (~@ (List/map product;right args)) + (~ g!actor-name) + (promise;Promise (~ return))))] + (` (def: (~@ (common;gen-export-level _ex-lev)) ((~ (ast;symbol ["" name])) (~@ arg-names) (~ g!self)) + (~ type) + (let [(~ g!output) (promise;promise (~ return))] + (exec (send ((~ (ast;tag ["" name])) [[(~@ arg-names)] (~ g!output)]) (~ g!self)) + (~ g!output)))))))) + methods)] + (wrap (list& (` (type: (~@ (common;gen-export-level _ex-lev)) (~ g!state-name) (~ state-type))) + (` (type: (~@ (common;gen-export-level _ex-lev)) (~ g!protocol-name) (~@ protocol))) + (` (type: (~@ (common;gen-export-level _ex-lev)) (~ g!actor-name) (Actor (~ g!state-name) (~ g!protocol-name)))) + (` (def: (~@ (common;gen-export-level _ex-lev)) (~@ (actor-def-decl decl (` (Proc (~ g!state-name) (~ g!protocol-name))))) + (~ g!proc))) + g!methods)) + ))) diff --git a/stdlib/source/lux/concurrency/atom.lux b/stdlib/source/lux/concurrency/atom.lux new file mode 100644 index 000000000..3905ee7ca --- /dev/null +++ b/stdlib/source/lux/concurrency/atom.lux @@ -0,0 +1,41 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io #- run]) + host) + ) + +(jvm-import (java.util.concurrent.atomic.AtomicReference V) + (new [V]) + (compareAndSet [V V] boolean) + (get [] V)) + +(type: #export (Atom a) + (AtomicReference a)) + +(def: #export (atom value) + (All [a] (-> a (Atom a))) + (AtomicReference.new [value])) + +(def: #export (get atom) + (All [a] (-> (Atom a) (IO a))) + (io (AtomicReference.get [] atom))) + +(def: #export (compare-and-swap old new atom) + (All [a] (-> a a (Atom a) (IO Bool))) + (io (AtomicReference.compareAndSet [old new] atom))) + +(def: #export (update f atom) + (All [a] (-> (-> a a) (Atom a) (IO Unit))) + (io (let [old (AtomicReference.get [] atom)] + (if (AtomicReference.compareAndSet [old (f old)] atom) + [] + (io;run (update f atom)))))) + +(def: #export (set value atom) + (All [a] (-> a (Atom a) (IO Unit))) + (update (lambda [_] value) atom)) diff --git a/stdlib/source/lux/concurrency/frp.lux b/stdlib/source/lux/concurrency/frp.lux new file mode 100644 index 000000000..0efa9f837 --- /dev/null +++ b/stdlib/source/lux/concurrency/frp.lux @@ -0,0 +1,194 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + monad + eq) + (codata [io #- run] + function) + (data (struct [list]) + text/format) + [compiler] + (macro ["s" syntax #+ syntax: Syntax])) + (.. ["&" promise])) + +## [Types] +(type: #export (Chan a) + (&;Promise (Maybe [a (Chan a)]))) + +## [Syntax] +(syntax: #export (chan {?type (s;opt s;any)}) + {#;doc (doc "Makes an uninitialized Chan (in this case, of Unit)." + (chan Unit))} + (case ?type + (#;Some type) + (wrap (list (` (: (Chan (~ type)) + (&;promise))))) + + #;None + (wrap (list (` (&;promise)))))) + +## [Values] +(def: #export (filter p xs) + (All [a] (-> (-> a Bool) (Chan a) (Chan a))) + (do &;Monad + [?x+xs xs] + (case ?x+xs + #;None (wrap #;None) + (#;Some [x xs']) (if (p x) + (wrap (#;Some [x (filter p xs')])) + (filter p xs'))))) + +(def: #export (write value chan) + (All [a] (-> a (Chan a) (IO (Maybe (Chan a))))) + (case (&;poll chan) + (^template [ ] + + (do Monad + [#let [new-tail (&;promise)] + done? (&;resolve (#;Some [value new-tail]) )] + (if done? + (wrap (#;Some new-tail)) + (write value )))) + ([#;None chan] + [(#;Some (#;Some [_ chan'])) chan']) + + _ + (:: Monad wrap #;None) + )) + +(def: #export (close chan) + (All [a] (-> (Chan a) (IO Bool))) + (case (&;poll chan) + (^template [ ] + + (do Monad + [done? (&;resolve #;None )] + (if done? + (wrap true) + (close )))) + ([#;None chan] + [(#;Some (#;Some [_ chan'])) chan']) + + _ + (:: Monad wrap false) + )) + +(def: (pipe' input output) + (All [a] (-> (Chan a) (Chan a) (&;Promise Unit))) + (do &;Monad + [?x+xs input] + (case ?x+xs + #;None (wrap []) + (#;Some [x input']) (case (io;run (write x output)) + #;None + (wrap []) + + (#;Some output') + (pipe' input' output'))))) + +(def: #export (pipe input output) + (All [a] (-> (Chan a) (Chan a) (&;Promise Unit))) + (do &;Monad + [_ (pipe' input output)] + (exec (io;run (close output)) + (wrap [])))) + +(def: #export (merge xss) + (All [a] (-> (List (Chan a)) (Chan a))) + (let [output (chan ($ 0))] + (exec (do &;Monad + [_ (mapM @ (lambda [input] (pipe' input output)) xss)] + (exec (io;run (close output)) + (wrap []))) + output))) + +(def: #export (fold f init xs) + (All [a b] (-> (-> b a (&;Promise a)) a (Chan b) (&;Promise a))) + (do &;Monad + [?x+xs xs] + (case ?x+xs + #;None (wrap init) + (#;Some [x xs']) (do @ + [init' (f x init)] + (fold f init' xs'))))) + +(def: (no-dups' eq last-one xs) + (All [a] (-> (Eq a) a (Chan a) (Chan a))) + (let [(^open) eq] + (do &;Monad + [?x+xs xs] + (case ?x+xs + #;None (wrap #;None) + (#;Some [x xs']) (if (= x last-one) + (no-dups' eq last-one xs') + (wrap (#;Some [x (no-dups' eq x xs')]))))))) + +(def: #export (no-dups eq xs) + {#;doc "Multiple consecutive equal values in the input channel will just be single values in the output channel."} + (All [a] (-> (Eq a) (Chan a) (Chan a))) + (let [(^open) eq] + (do &;Monad + [?x+xs xs] + (case ?x+xs + #;None (wrap #;None) + (#;Some [x xs']) (wrap (#;Some [x (no-dups' eq x xs')])))))) + +(def: #export (consume xs) + (All [a] (-> (Chan a) (&;Promise (List a)))) + (do &;Monad + [?x+xs' xs] + (case ?x+xs' + #;None + (wrap #;Nil) + + (#;Some [x xs']) + (do @ + [=xs (consume xs')] + (wrap (#;Cons x =xs)))))) + +(def: #export (as-chan !x) + (All [a] (-> (&;Promise a) (Chan a))) + (do &;Monad + [x !x] + (wrap (#;Some [x (wrap #;None)])))) + +## [Structures] +(struct: #export _ (Functor Chan) + (def: (map f xs) + (:: &;Functor map + (lambda [?x+xs] + (case ?x+xs + #;None #;None + (#;Some [x xs']) (#;Some [(f x) (map f xs')]))) + xs))) + +(struct: #export _ (Applicative Chan) + (def: functor Functor) + + (def: (wrap a) + (let [(^open) &;Monad] + (wrap (#;Some [a (wrap #;None)])))) + + (def: (apply ff fa) + (let [fb (chan ($ 1))] + (exec (let [(^open) Functor] + (map (lambda [f] (pipe (map f fa) fb)) + ff)) + fb)))) + +(struct: #export _ (Monad Chan) + (def: applicative Applicative) + + (def: (join mma) + (let [output (chan ($ 0))] + (exec (let [(^open) Functor] + (map (lambda [ma] + (pipe ma output)) + mma)) + output)))) diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux new file mode 100644 index 000000000..b765acc4d --- /dev/null +++ b/stdlib/source/lux/concurrency/promise.lux @@ -0,0 +1,233 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (data (struct [list #* "" Functor]) + number + text/format + error) + (codata [io #- run] + function) + (control functor + applicative + monad) + [compiler] + (macro ["s" syntax #+ syntax: Syntax]) + (concurrency [atom #+ Atom atom]) + host + )) + +(jvm-import java.lang.Runtime + (#static getRuntime [] Runtime) + (availableProcessors [] int)) + +(jvm-import java.lang.Runnable) + +(jvm-import java.lang.Thread + (new [Runnable]) + (start [] void)) + +(jvm-import java.util.concurrent.Executor + (execute [Runnable] void)) + +(jvm-import java.util.concurrent.TimeUnit + (#enum MILLISECONDS)) + +(jvm-import (java.util.concurrent.ScheduledFuture a)) + +(jvm-import java.util.concurrent.ScheduledThreadPoolExecutor + (new [int]) + (schedule [Runnable long TimeUnit] (ScheduledFuture Object))) + +(def: #export concurrency-level + Nat + (|> (Runtime.getRuntime []) + (Runtime.availableProcessors []) + int-to-nat)) + +(def: executor + ScheduledThreadPoolExecutor + (ScheduledThreadPoolExecutor.new [(nat-to-int concurrency-level)])) + +(syntax: (runnable expr) + (wrap (list (`' (object [java.lang.Runnable] + [] + (java.lang.Runnable (run) void + (exec (~ expr) + []))))))) + +(type: (Promise-State a) + {#value (Maybe a) + #observers (List (-> a (IO Unit)))}) + +(type: #export (Promise a) + {#;doc "Represents values produced by promisehronous computations (unlike IO, which is synchronous)."} + (Atom (Promise-State a))) + +(def: #hidden (promise' ?value) + (All [a] (-> (Maybe a) (Promise a))) + (atom {#value ?value + #observers (list)})) + +(syntax: #export (promise {?type (s;opt s;any)}) + {#;doc (doc "Makes an uninitialized Promise (in this example, of Unit)." + (promise Unit))} + (case ?type + (#;Some type) + (wrap (list (` (: (Promise (~ type)) + (promise' #;None))))) + + #;None + (wrap (list (` (promise' #;None)))))) + +(def: #export (poll promise) + {#;doc "Checks whether an Promise's value has already been resolved."} + (All [a] (-> (Promise a) (Maybe a))) + (|> (atom;get promise) + io;run + (get@ #value))) + +(def: #export (resolve value promise) + {#;doc "Sets an Promise's value if it hasn't been done yet."} + (All [a] (-> a (Promise a) (IO Bool))) + (do Monad + [old (atom;get promise)] + (case (get@ #value old) + (#;Some _) + (wrap false) + + #;None + (do @ + [#let [new (set@ #value (#;Some value) old)] + succeeded? (atom;compare-and-swap old new promise)] + (if succeeded? + (do @ + [_ (mapM @ (lambda [f] (f value)) + (get@ #observers old))] + (wrap true)) + (resolve value promise)))))) + +(def: (await f promise) + (All [a] (-> (-> a (IO Unit)) (Promise a) Unit)) + (let [old (io;run (atom;get promise))] + (case (get@ #value old) + (#;Some value) + (io;run (f value)) + + #;None + (let [new (update@ #observers (|>. (#;Cons f)) old)] + (if (io;run (atom;compare-and-swap old new promise)) + [] + (await f promise)))))) + +(struct: #export _ (Functor Promise) + (def: (map f fa) + (let [fb (promise ($ 1))] + (exec (await (lambda [a] (do Monad + [_ (resolve (f a) fb)] + (wrap []))) + fa) + fb)))) + +(struct: #export _ (Applicative Promise) + (def: functor Functor) + + (def: (wrap a) + (atom {#value (#;Some a) + #observers (list)})) + + (def: (apply ff fa) + (let [fb (promise ($ 1))] + (exec (await (lambda [f] + (io (await (lambda [a] (do Monad + [_ (resolve (f a) fb)] + (wrap []))) + fa))) + ff) + fb)) + )) + +(struct: #export _ (Monad Promise) + (def: applicative Applicative) + + (def: (join mma) + (let [ma (promise ($ 0))] + (exec (await (lambda [ma'] + (io (await (lambda [a'] + (do Monad + [_ (resolve a' ma)] + (wrap []))) + ma'))) + mma) + ma)))) + +(def: #export (seq left right) + {#;doc "Sequencing combinator."} + (All [a b] (-> (Promise a) (Promise b) (Promise [a b]))) + (do Monad + [a left + b right] + (wrap [a b]))) + +(def: #export (alt left right) + {#;doc "Heterogeneous alternative combinator."} + (All [a b] (-> (Promise a) (Promise b) (Promise (| a b)))) + (let [a|b (promise (Either ($ 0) ($ 1)))] + (let% [ (do-template [ ] + [(await (lambda [value] + (do Monad + [_ (resolve ( value) a|b)] + (wrap []))) + )] + + [left #;Left] + [right #;Right] + )] + (exec + a|b)))) + +(def: #export (either left right) + {#;doc "Homogeneous alternative combinator."} + (All [a] (-> (Promise a) (Promise a) (Promise a))) + (let [left||right (promise ($ 0))] + (let% [ (do-template [] + [(await [(lambda [value] + (do Monad + [_ (resolve value left||right)] + (wrap [])))] + )] + + [left] + [right] + )] + (exec + left||right)))) + +(def: #export (future computation) + {#;doc "Runs computation on it's own process and returns an Promise that will eventually host it's result."} + (All [a] (-> (IO a) (Promise a))) + (let [!out (promise ($ 0))] + (exec (Thread.start [] (Thread.new [(runnable (io;run (resolve (io;run computation) + !out)))])) + !out))) + +(def: #export (wait time) + (-> Nat (Promise Unit)) + (let [!out (promise Unit)] + (exec (ScheduledThreadPoolExecutor.schedule [(runnable (io;run (resolve [] !out))) + (nat-to-int time) + TimeUnit.MILLISECONDS] + executor) + !out))) + +(def: #export (time-out time promise) + (All [a] (-> Nat (Promise a) (Promise (Maybe a)))) + (alt (wait time) promise)) + +(def: #export (delay time value) + {#;doc "Delivers a value after a certain period has passed."} + (All [a] (-> Nat a (Promise a))) + (:: Functor map (const value) (wait time))) diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux new file mode 100644 index 000000000..80633a41e --- /dev/null +++ b/stdlib/source/lux/concurrency/stm.lux @@ -0,0 +1,237 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + monad) + (codata [io #- run]) + (data (struct [list #* "List/" Functor] + [dict #+ Dict]) + [product] + [text] + text/format) + host + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax]) + (concurrency [atom #+ Atom atom] + [promise #+ Promise "Promise/" Monad] + [frp]) + )) + +(type: (Var-State a) + {#value a + #observers (Dict Text (-> a (IO Unit)))}) + +(type: #export (Var a) + (Atom (Var-State a))) + +(type: (Tx-Frame a) + {#var (Var a) + #original a + #current a}) + +(type: Tx + (List (Ex [a] (Tx-Frame a)))) + +(type: #export (STM a) + (-> Tx [Tx a])) + +(def: #export (var value) + (All [a] (-> a (Var a))) + (atom;atom {#value value + #observers (dict;new text;Hash)})) + +(def: raw-read + (All [a] (-> (Var a) a)) + (|>. atom;get io;run (get@ #value))) + +(def: (find-var-value var tx) + (All [a] (-> (Var a) Tx (Maybe a))) + (:! (Maybe ($ 0)) + (find (: (-> (Ex [a] (Tx-Frame a)) + (Maybe Unit)) + (lambda [[_var _original _current]] + (:! (Maybe Unit) + (if (== (:! (Var Unit) var) + (:! (Var Unit) _var)) + (#;Some _current) + #;None)))) + tx))) + +(def: #export (read var) + (All [a] (-> (Var a) (STM a))) + (lambda [tx] + (case (find-var-value var tx) + (#;Some value) + [tx value] + + #;None + (let [value (raw-read var)] + [(#;Cons [var value value] tx) + value])))) + +(def: #export (read! var) + {#;doc "Reads var immediately, without going through a transaction."} + (All [a] (-> (Var a) (IO a))) + (|> var + atom;get + (:: Functor map (get@ #value)))) + +(def: (update-tx-value var value tx) + (All [a] (-> (Var a) a Tx Tx)) + (case tx + #;Nil + #;Nil + + (#;Cons [_var _original _current] tx') + (if (== (:! (Var ($ 0)) var) + (:! (Var ($ 0)) _var)) + (#;Cons [(:! (Var ($ 0)) _var) + (:! ($ 0) _original) + (:! ($ 0) _current)] + tx') + (#;Cons [_var _original _current] + (update-tx-value var value tx'))) + )) + +(def: #export (write value var) + (All [a] (-> a (Var a) (STM Unit))) + (lambda [tx] + (case (find-var-value var tx) + (#;Some _) + [(update-tx-value var value tx) + []] + + #;None + [(#;Cons [var (raw-read var) value] tx) + []]))) + +(def: #export (write! new-value var) + {#;doc "Writes value to var immediately, without going through a transaction."} + (All [a] (-> a (Var a) (IO Unit))) + (do Monad + [old (atom;get var) + #let [old-value (get@ #value old) + new (set@ #value new-value old)] + succeeded? (atom;compare-and-swap old new var)] + (if succeeded? + (do @ + [_ (|> old + (get@ #observers) + dict;values + (mapM @ (lambda [f] (f new-value))))] + (wrap [])) + (write! new-value var)))) + +(def: #export (unfollow label target) + (All [a] (-> Text (Var a) (IO Unit))) + (do Monad + [[value observers] (atom;get target)] + (atom;set [value (dict;remove label observers)] + target))) + +(def: #export (follow label target) + {#;doc "Creates a channel (identified by a given text) that will receive all changes to the value of the given var."} + (All [a] (-> Text (Var a) (IO (frp;Chan a)))) + (let [head (frp;chan ($ 0)) + chan-var (var head) + observer (lambda [value] + (case (io;run (|> chan-var raw-read (frp;write value))) + #;None + ## By closing the output Chan, the + ## observer becomes obsolete. + (unfollow label chan-var) + + (#;Some tail') + (write! tail' chan-var)))] + (do Monad + [_ (atom;update (lambda [[value observers]] + [value (dict;put label observer observers)]) + target)] + (wrap head)))) + +(struct: #export _ (Functor STM) + (def: (map f fa) + (lambda [tx] + (let [[tx' a] (fa tx)] + [tx' (f a)])))) + +(struct: #export _ (Applicative STM) + (def: functor Functor) + + (def: (wrap a) + (lambda [tx] [tx a])) + + (def: (apply ff fa) + (lambda [tx] + (let [[tx' f] (ff tx) + [tx'' a] (fa tx')] + [tx'' (f a)])))) + +(struct: #export _ (Monad STM) + (def: applicative Applicative) + + (def: (join mma) + (lambda [tx] + (let [[tx' ma] (mma tx)] + (ma tx'))))) + +(def: #export (update! f var) + (All [a] (-> (-> a a) (Var a) (Promise [a a]))) + (promise;future (io (loop [_ []] + (let [(^@ state [value observers]) (io;run (atom;get var)) + value' (f value)] + (if (io;run (atom;compare-and-swap state + [value' observers] + var)) + [value value'] + (recur []))))))) + +(def: #export (update f var) + (All [a] (-> (-> a a) (Var a) (STM [a a]))) + (do Monad + [a (read var) + #let [a' (f a)] + _ (write a' var)] + (wrap [a a']))) + +(def: (can-commit? tx) + (-> Tx Bool) + (every? (lambda [[_var _original _current]] + (== _original (raw-read _var))) + tx)) + +(def: (commit-var [_var _original _current]) + (-> (Ex [a] (Tx-Frame a)) Unit) + (if (== _original _current) + [] + (io;run (write! _current _var)))) + +(def: fresh-tx Tx (list)) + +(def: (commit' output stm-proc) + (All [a] (-> (Promise a) (STM a) (Promise Unit))) + (promise;future (io (let [[finished-tx value] (stm-proc fresh-tx)] + (if (can-commit? finished-tx) + (exec (List/map commit-var finished-tx) + (io;run (promise;resolve value output)) + []) + (exec (commit' output stm-proc) + [])) + )))) + +(def: #export (commit stm-proc) + {#;doc "Commits a transaction and returns its result (asynchronously). + + Note that a transaction may be re-run an indeterminate number of times if other transactions involving the same variables successfully commit first. + + For this reason, it's important to note that transactions must be free from side-effects, such as I/O."} + (All [a] (-> (STM a) (Promise a))) + (let [output (promise;promise)] + (exec (commit' output stm-proc) + output))) diff --git a/stdlib/source/lux/control/applicative.lux b/stdlib/source/lux/control/applicative.lux new file mode 100644 index 000000000..5d4cad0c0 --- /dev/null +++ b/stdlib/source/lux/control/applicative.lux @@ -0,0 +1,33 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (.. ["F" functor])) + +(sig: #export (Applicative f) + (: (F;Functor f) + functor) + (: (All [a] + (-> a (f a))) + wrap) + (: (All [a b] + (-> (f (-> a b)) (f a) (f b))) + apply)) + +(def: #export (compA Applicative Applicative) + (All [F G] (-> (Applicative F) (Applicative G) (Applicative (All [a] (F (G a)))))) + (struct (def: functor (F;compF (get@ #functor Applicative) + (get@ #functor Applicative))) + (def: wrap + (|>. (:: Applicative wrap) (:: Applicative wrap))) + (def: (apply fgf fgx) + (let [applyF (:: Applicative apply) + applyG (:: Applicative apply)] + ($_ applyF + (:: Applicative wrap applyG) + fgf + fgx))) + )) diff --git a/stdlib/source/lux/control/bounded.lux b/stdlib/source/lux/control/bounded.lux new file mode 100644 index 000000000..291c4d8b6 --- /dev/null +++ b/stdlib/source/lux/control/bounded.lux @@ -0,0 +1,14 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux) + +## Signatures +(sig: #export (Bounded a) + (: a + top) + + (: a + bottom)) diff --git a/stdlib/source/lux/control/codec.lux b/stdlib/source/lux/control/codec.lux new file mode 100644 index 000000000..e9833ccc9 --- /dev/null +++ b/stdlib/source/lux/control/codec.lux @@ -0,0 +1,28 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux control/monad + data/error)) + +## [Signatures] +(sig: #export (Codec m a) + (: (-> a m) + encode) + (: (-> m (Error a)) + decode)) + +## [Values] +(def: #export (<.> (^open "bc:") (^open "ab:")) + (All [a b c] (-> (Codec c b) (Codec b a) (Codec c a))) + (struct + (def: encode (|>. ab:encode bc:encode)) + + (def: (decode cy) + (do Monad + [by (bc:decode cy)] + (ab:decode by))) + )) diff --git a/stdlib/source/lux/control/comonad.lux b/stdlib/source/lux/control/comonad.lux new file mode 100644 index 000000000..801dbb479 --- /dev/null +++ b/stdlib/source/lux/control/comonad.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + ["F" ../functor] + [lux/data/struct/list #* "" Fold]) + +## [Signatures] +(sig: #export (CoMonad w) + (: (F;Functor w) + functor) + (: (All [a] + (-> (w a) a)) + unwrap) + (: (All [a] + (-> (w a) (w (w a)))) + split)) + +## [Syntax] +(macro: #export (be tokens state) + {#;doc (doc "A co-monadic parallel to the \"do\" macro." + (let [square (lambda [n] (* n n))] + (be CoMonad + [inputs (iterate inc 2)] + (square (head inputs)))))} + (case tokens + (#;Cons comonad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) + (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])]) + g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) + g!split (: AST [["" -1 -1] (#;SymbolS ["" " split "])]) + body' (fold (: (-> [AST AST] AST AST) + (lambda [binding body'] + (let [[var value] binding] + (case var + [_ (#;TagS ["" "let"])] + (` (let (~ value) (~ body'))) + + _ + (` (|> (~ value) (~ g!split) ((~ g!map) (lambda [(~ var)] (~ body'))))) + )))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (#;Cons (` (;_lux_case (~ comonad) + (~ g!@) + (;_lux_case (~ g!@) + {#functor {#F;map (~ g!map)} #unwrap (~' unwrap) #split (~ g!split)} + (~ body')))) + #;Nil)])) + + _ + (#;Left "Wrong syntax for be"))) diff --git a/stdlib/source/lux/control/effect.lux b/stdlib/source/lux/control/effect.lux new file mode 100644 index 000000000..cbd24c7f9 --- /dev/null +++ b/stdlib/source/lux/control/effect.lux @@ -0,0 +1,315 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux + (lux (control ["F" functor] + applicative + monad) + (codata [io #- run]) + (data (struct [list "List/" Monad]) + [number "Nat/" Codec] + text/format + error) + [compiler] + [macro] + (macro [ast] + ["s" syntax #+ syntax: Syntax] + (syntax [common])) + [type] + (type ["tc" check]))) + +## [Type] +(type: #export (Eff F a) + (#Pure a) + (#Effect (F (Eff F a)))) + +(sig: #export (Handler E M) + (: (All [a] (-> (Eff E a) (M a))) + handle)) + +## [Values] +(struct: #export (Functor dsl) + (All [F] (-> (F;Functor F) (F;Functor (Eff F)))) + (def: (map f ea) + (case ea + (#Pure a) + (#Pure (f a)) + + (#Effect value) + (#Effect (:: dsl map (map f) value))))) + +(struct: #export (Applicative dsl) + (All [F] (-> (F;Functor F) (Applicative (Eff F)))) + (def: functor (Functor dsl)) + + (def: (wrap a) + (#Pure a)) + + (def: (apply ef ea) + (case [ef ea] + [(#Pure f) (#Pure a)] + (#Pure (f a)) + + [(#Pure f) (#Effect fa)] + (#Effect (:: dsl map + (:: (Functor dsl) map f) + fa)) + + [(#Effect ff) _] + (#Effect (:: dsl map + (lambda [f] (apply f ea)) + ff)) + ))) + +(struct: #export (Monad dsl) + (All [F] (-> (F;Functor F) (Monad (Eff F)))) + (def: applicative (Applicative dsl)) + + (def: (join efefa) + (case efefa + (#Pure efa) + (case efa + (#Pure a) + (#Pure a) + + (#Effect fa) + (#Effect fa)) + + (#Effect fefa) + (#Effect (:: dsl map + (:: (Monad dsl) join) + fefa)) + ))) + +(type: (@| L R) + (All [a] (| (L a) (R a)))) + +(def: #export (combine-functors left right) + (All [L R] + (-> (F;Functor L) (F;Functor R) + (F;Functor (@| L R)))) + (struct + (def: (map f l|r) + (case l|r + (+0 l) (+0 (:: left map f l)) + (+1 r) (+1 (:: right map f r))) + ))) + +(def: #export (combine-handlers Monad left right) + (All [L R M] + (-> (Monad M) + (Handler L M) (Handler R M) + (Handler (@| L R) M))) + (struct + (def: (handle el|r) + (case el|r + (#Pure x) + (:: Monad wrap x) + + (#Effect l|r) + (case l|r + (#;Left l) (:: left handle (#Effect l)) + (#;Right r) (:: right handle (#Effect r)) + )) + ))) + +## [Syntax] +(syntax: #export (||E {effects (s;some s;any)}) + (do @ + [g!a (compiler;gensym "g!a") + #let [effects@a (List/map (lambda [eff] (` ((~ eff) (~ g!a)))) + effects)]] + (wrap (list (` (All [(~ g!a)] + (| (~@ effects@a)))) + )))) + +(syntax: #export (||F {functors (s;many s;any)}) + (wrap (list (` ($_ ;;combine-functors (~@ functors)))))) + +(syntax: #export (||H monad {handlers (s;many s;any)}) + (do @ + [g!combiner (compiler;gensym "")] + (wrap (list (` (let [(~ g!combiner) (;;combine-handlers (~ monad))] + ($_ (~ g!combiner) (~@ handlers)))))))) + +(type: Op + {#name Text + #inputs (List AST) + #output AST}) + +(def: op^ + (Syntax Op) + (s;form (s;either ($_ s;seq + s;local-symbol + (s;tuple (s;some s;any)) + s;any) + ($_ s;seq + s;local-symbol + (:: s;Monad wrap (list)) + s;any)))) + +(syntax: #export (effect: {exp-lvl common;export-level} + {name s;local-symbol} + {ops (s;many op^)}) + (do @ + [g!output (compiler;gensym "g!output") + #let [op-types (List/map (lambda [op] + (let [g!tag (ast;tag ["" (get@ #name op)]) + g!inputs (` [(~@ (get@ #inputs op))]) + g!output (` (-> (~ (get@ #output op)) (~ g!output)))] + (` ((~ g!tag) (~ g!inputs) (~ g!output))))) + ops) + type-name (ast;symbol ["" name]) + type-def (` (type: (~@ (common;gen-export-level exp-lvl)) + ((~ type-name) (~ g!output)) + (~@ op-types))) + op-tags (List/map (|>. (get@ #name) [""] ast;tag (list) ast;tuple) + ops) + functor-def (` (struct: (~@ (common;gen-export-level exp-lvl)) (~' _) (F;Functor (~ type-name)) + (def: ((~' map) (~' f) (~' fa)) + (case (~' fa) + (^template [(~' )] + ((~' ) (~' params) (~' cont)) + ((~' ) (~' params) (. (~' f) (~' cont)))) + ((~@ op-tags)))) + )) + function-defs (List/map (lambda [op] + (let [g!name (ast;symbol ["" (get@ #name op)]) + g!tag (ast;tag ["" (get@ #name op)]) + g!params (: (List AST) + (case (list;size (get@ #inputs op)) + +0 (list) + s (|> (list;range+ +0 (dec+ s)) + (List/map (|>. Nat/encode + (format "_") + [""] + ast;symbol)))))] + (` (def: (~@ (common;gen-export-level exp-lvl)) ((~ g!name) (~@ g!params)) + (-> (~@ (get@ #inputs op)) + ((~ type-name) (~ (get@ #output op)))) + ((~ g!tag) [(~@ g!params)] ;id))))) + ops)]] + (wrap (list& type-def + functor-def + function-defs)))) + +(type: Translation + {#effect Ident + #base AST + #monad AST}) + +(def: translation^ + (Syntax Translation) + (s;form (do s;Monad + [_ (s;symbol! ["" "=>"])] + (s;seq s;symbol + (s;tuple (s;seq s;any + s;any)))))) + +(syntax: #export (handler: {exp-lvl common;export-level} + {name s;local-symbol} + {[effect base monad] translation^} + {defs (s;many (common;def *compiler*))}) + (do @ + [(^@ effect [e-module _]) (compiler;un-alias effect) + g!input (compiler;gensym "g!input") + g!cont (compiler;gensym "g!cont") + g!value (compiler;gensym "value") + #let [g!cases (|> defs + (List/map (lambda [def] + (let [g!tag (ast;tag [e-module (get@ #common;def-name def)]) + g!args (List/map (|>. [""] ast;symbol) + (get@ #common;def-args def)) + eff-calc (case (get@ #common;def-type def) + #;None + (get@ #common;def-value def) + + (#;Some type) + (` (: (~ type) (~ (get@ #common;def-value def))))) + invocation (case g!args + #;Nil + eff-calc + + _ + (` ((~ eff-calc) (~@ g!args))))] + (list (` ((~ g!tag) [(~@ g!args)] (~ g!cont))) + (` (do (~ monad) + [(~ g!value) (~ invocation)] + ((~' handle) ((~ g!cont) (~ g!value))))) + )))) + List/join)]] + (wrap (list (` (struct: (~@ (common;gen-export-level exp-lvl)) (~ (ast;symbol ["" name])) + (;;Handler (~ (ast;symbol effect)) (~ base)) + (def: ((~' handle) (~ g!input)) + (case (~ g!input) + (#Pure (~ g!input)) + (:: (~ monad) (~' wrap) (~ g!input)) + + (#Effect (~ g!input)) + (case (~ g!input) + (~@ g!cases)))))))))) + +(syntax: #export (with-handler handler body) + (wrap (list (` (:: (~ handler) (~' handle) (~ body)))))) + +(def: (un-apply type-app) + (-> Type Type) + (case type-app + (#;AppT effect value) + effect + + _ + (error! (format "Wrong type format: " (type;type-to-text type-app))))) + +(def: (clean-effect effect) + (-> Type Type) + (case effect + (#;UnivQ env body) + (#;UnivQ (list) body) + + _ + (error! (format "Wrong effect format: " (type;type-to-text effect))))) + +(def: g!functor AST (ast;symbol ["" "%E"])) + +(syntax: #export (doE functor {bindings (s;tuple (s;some s;any))} body) + (do @ + [g!output (compiler;gensym "")] + (wrap (list (` (let [(~ g!functor) (~ functor)] + (do (Monad (~ g!functor)) + [(~@ bindings) + (~ g!output) (~ body)] + ((~' wrap) (~ g!output))))))))) + +(syntax: #export (lift {value (s;alt s;symbol + s;any)}) + (case value + (#;Left var) + (do @ + [input (compiler;find-type var) + output compiler;expected-type] + (case [input output] + (^=> [(#;AppT eff0 _) (#;AppT stackT0 recT0)] + {(type;apply-type stackT0 recT0) (#;Some unfoldT0)} + {stackT0 (^ (#;AppT (#;NamedT (ident-for ;;Eff) _) + stackT1))} + {(type;apply-type stackT1 recT0) (#;Some unfoldT1)} + {(list;find (lambda [[idx effect]] + (if (tc;checks? (clean-effect effect) eff0) + (#;Some idx) + #;None)) + (|> unfoldT1 type;flatten-sum (List/map un-apply) list;enumerate)) + (#;Some idx)}) + (wrap (list (` (#;;Effect (:: (~ g!functor) (~' map) (~' wrap) ((~ (ast;int (nat-to-int idx))) + (~ (ast;symbol var)))))))) + + _ + (compiler;fail (format "Invalid type to lift: " (type;type-to-text output))))) + + (#;Right node) + (do @ + [g!value (compiler;gensym "")] + (wrap (list (` (let [(~ g!value) (~ node)] + (;;lift (~ g!value))))))))) diff --git a/stdlib/source/lux/control/enum.lux b/stdlib/source/lux/control/enum.lux new file mode 100644 index 000000000..63c041f95 --- /dev/null +++ b/stdlib/source/lux/control/enum.lux @@ -0,0 +1,24 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux + (lux/control [ord])) + +## [Signatures] +(sig: #export (Enum e) + (: (ord;Ord e) ord) + (: (-> e e) succ) + (: (-> e e) pred)) + +## [Functions] +(def: (range' <= succ from to) + (All [a] (-> (-> a a Bool) (-> a a) a a (List a))) + (if (<= to from) + (#;Cons from (range' <= succ (succ from) to)) + #;Nil)) + +(def: #export (range (^open) from to) + (All [a] (-> (Enum a) a a (List a))) + (range' <= succ from to)) diff --git a/stdlib/source/lux/control/eq.lux b/stdlib/source/lux/control/eq.lux new file mode 100644 index 000000000..357780fcd --- /dev/null +++ b/stdlib/source/lux/control/eq.lux @@ -0,0 +1,29 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux) + +(sig: #export (Eq a) + (: (-> a a Bool) + =)) + +(def: #export (conj left right) + (All [l r] (-> (Eq l) (Eq r) (Eq [l r]))) + (struct (def: (= [a b] [x y]) + (and (:: left = a x) + (:: right = b y))))) + +(def: #export (disj left right) + (All [l r] (-> (Eq l) (Eq r) (Eq (| l r)))) + (struct (def: (= a|b x|y) + (case [a|b x|y] + [(+0 a) (+0 x)] + (:: left = a x) + + [(+1 b) (+1 y)] + (:: right = b y) + + _ + false)))) diff --git a/stdlib/source/lux/control/fold.lux b/stdlib/source/lux/control/fold.lux new file mode 100644 index 000000000..6e56dacee --- /dev/null +++ b/stdlib/source/lux/control/fold.lux @@ -0,0 +1,12 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux) + +## [Signatures] +(sig: #export (Fold F) + (: (All [a b] + (-> (-> b a a) a (F b) a)) + fold)) diff --git a/stdlib/source/lux/control/functor.lux b/stdlib/source/lux/control/functor.lux new file mode 100644 index 000000000..711c5ae16 --- /dev/null +++ b/stdlib/source/lux/control/functor.lux @@ -0,0 +1,16 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux) + +(sig: #export (Functor f) + (: (All [a b] + (-> (-> a b) (f a) (f b))) + map)) + +(def: #export (compF Functor Functor) + (All [F G] (-> (Functor F) (Functor G) (Functor (All [a] (F (G a)))))) + (struct (def: (map f fga) + (:: Functor map (:: Functor map f) fga)))) diff --git a/stdlib/source/lux/control/hash.lux b/stdlib/source/lux/control/hash.lux new file mode 100644 index 000000000..d8ae926ad --- /dev/null +++ b/stdlib/source/lux/control/hash.lux @@ -0,0 +1,15 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (.. eq)) + +## [Signatures] +(sig: #export (Hash a) + (: (Eq a) + eq) + (: (-> a Nat) + hash)) diff --git a/stdlib/source/lux/control/monad.lux b/stdlib/source/lux/control/monad.lux new file mode 100644 index 000000000..71a873704 --- /dev/null +++ b/stdlib/source/lux/control/monad.lux @@ -0,0 +1,142 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (.. (functor #as F) + (applicative #as A))) + +## [Utils] +(def: (fold f init xs) + (All [a b] + (-> (-> b a a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons x xs') + (fold f (f x init) xs'))) + +(def: (map f xs) + (All [a b] + (-> (-> a b) (List a) (List b))) + (case xs + #;Nil + #;Nil + + (#;Cons x xs') + (#;Cons (f x) (map f xs')))) + +(def: (reverse xs) + (All [a] + (-> (List a) (List a))) + (fold (lambda [head tail] (#;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] +(sig: #export (Monad m) + (: (A;Applicative m) + applicative) + (: (All [a] + (-> (m (m a)) (m a))) + join)) + +## [Syntax] +(macro: #export (do tokens state) + {#;doc (doc "Macro for easy concatenation of monadic operations." + (do Monad + [y (f1 x) + z (f2 z)] + (wrap (f3 z))))} + (case tokens + (#;Cons monad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) + (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])]) + g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) + g!join (: AST [["" -1 -1] (#;SymbolS ["" " join "])]) + g!apply (: AST [["" -1 -1] (#;SymbolS ["" " apply "])]) + body' (fold (: (-> [AST AST] AST AST) + (lambda [binding body'] + (let [[var value] binding] + (case var + [_ (#;TagS ["" "let"])] + (` (let (~ value) (~ body'))) + + _ + (` (|> (~ value) ((~ g!map) (lambda [(~ var)] (~ body'))) (~ g!join))) + )))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (#;Cons (` (;_lux_case (~ monad) + (~ g!@) + (;_lux_case (~ g!@) + {#applicative {#A;functor {#F;map (~ g!map)} + #A;wrap (~' wrap) + #A;apply (~ g!apply)} + #join (~ g!join)} + (~ body')))) + #;Nil)])) + + _ + (#;Left "Wrong syntax for do"))) + +## [Functions] +(def: #export (seqM monad xs) + (All [M a] + (-> (Monad M) (List (M a)) (M (List a)))) + (case xs + #;Nil + (:: monad wrap #;Nil) + + (#;Cons x xs') + (do monad + [_x x + _xs (seqM monad xs')] + (wrap (#;Cons _x _xs))) + )) + +(def: #export (mapM monad f xs) + (All [M a b] + (-> (Monad M) (-> a (M b)) (List a) (M (List b)))) + (case xs + #;Nil + (:: monad wrap #;Nil) + + (#;Cons x xs') + (do monad + [_x (f x) + _xs (mapM monad f xs')] + (wrap (#;Cons _x _xs))) + )) + +(def: #export (foldM monad f init xs) + (All [M a b] + (-> (Monad M) (-> b a (M a)) a (List b) + (M a))) + (case xs + #;Nil + (:: monad wrap init) + + (#;Cons x xs') + (do monad + [init' (f x init)] + (foldM monad f init' xs')))) + +(def: #export (liftM Monad f) + (All [M a b] + (-> (Monad M) (-> a b) (-> (M a) (M b)))) + (lambda [ma] + (do Monad + [a ma] + (wrap (f a))))) diff --git a/stdlib/source/lux/control/monoid.lux b/stdlib/source/lux/control/monoid.lux new file mode 100644 index 000000000..67f6d868c --- /dev/null +++ b/stdlib/source/lux/control/monoid.lux @@ -0,0 +1,13 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux) + +## Signatures +(sig: #export (Monoid a) + (: a + unit) + (: (-> a a a) + append)) diff --git a/stdlib/source/lux/control/number.lux b/stdlib/source/lux/control/number.lux new file mode 100644 index 000000000..d6e9a42b6 --- /dev/null +++ b/stdlib/source/lux/control/number.lux @@ -0,0 +1,22 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux/control [ord])) + +## [Signatures] +(sig: #export (Number n) + (: (ord;Ord n) + ord) + + (do-template [] + [(: (-> n n n) )] + [+] [-] [*] [/] [%]) + + (do-template [] + [(: (-> n n) )] + [negate] [signum] [abs]) + ) diff --git a/stdlib/source/lux/control/ord.lux b/stdlib/source/lux/control/ord.lux new file mode 100644 index 000000000..0021cbe1b --- /dev/null +++ b/stdlib/source/lux/control/ord.lux @@ -0,0 +1,44 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + [lux #- min max] + (.. eq) + lux/codata/function) + +## [Signatures] +(sig: #export (Ord a) + (: (Eq a) + eq) + + (do-template [] + [(: (-> a a Bool) )] + + [<] [<=] [>] [>=])) + +## [Values] +(def: #export (ord eq <) + (All [a] + (-> (Eq a) (-> a a Bool) (Ord a))) + (let [> (flip <)] + (struct + (def: eq eq) + (def: < <) + (def: (<= test subject) + (or (< test subject) + (:: eq = test subject))) + (def: > >) + (def: (>= test subject) + (or (> test subject) + (:: eq = test subject)))))) + +(do-template [ ] + [(def: #export ( ord x y) + (All [a] + (-> (Ord a) a a a)) + (if (:: ord y x) x y))] + + [max >] + [min <]) diff --git a/stdlib/source/lux/data/bit.lux b/stdlib/source/lux/data/bit.lux new file mode 100644 index 000000000..72a92507c --- /dev/null +++ b/stdlib/source/lux/data/bit.lux @@ -0,0 +1,66 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: [lux #- & | ^]) + +## [Values] +(do-template [ ] + [(def: #export ( param subject) + {#;doc } + (-> Nat ) + (_lux_proc ["bit" ] [subject param]))] + + [& "and" "Bit and." Nat] + [| "or" "Bit or." Nat] + [^ "xor" "Bit xor." Nat] + [<< "shift-left" "Bit shift-left." Nat] + [>> "shift-right" "Bit shift-right." Int] + [>>> "unsigned-shift-right" "Bit unsigned-shift-right." Nat] + ) + +(def: #export (count subject) + {#;doc "Count the number of 1s in a bit-map."} + (-> Nat Nat) + (_lux_proc ["bit" "count"] [subject])) + +(def: mask Nat (int-to-nat -1)) + +(def: #export ~ + {#;doc "Bit negation."} + (-> Nat Nat) + (^ mask)) + +(def: #export (clear idx input) + {#;doc "Clear bit at given index."} + (-> Nat Nat Nat) + (& (~ (<< idx +1)) input)) + +(do-template [ ] + [(def: #export ( idx input) + {#;doc } + (-> Nat Nat Nat) + ( (<< idx +1) input))] + + [set | "Set bit at given index."] + [flip ^ "Flip bit at given index."] + ) + +(def: #export (set? idx input) + (-> Nat Nat Bool) + (|> input (& (<< idx +1)) (=+ +0) not)) + +(def: rot-top Nat +64) + +(do-template [
] + [(def: #export ( distance input) + (-> Nat Nat Nat) + (| (
distance input) + ( (-+ (%+ rot-top distance) + rot-top) + input)))] + + [rotate-left << >>>] + [rotate-right >>> <<] + ) diff --git a/stdlib/source/lux/data/bool.lux b/stdlib/source/lux/data/bool.lux new file mode 100644 index 000000000..15dc349ef --- /dev/null +++ b/stdlib/source/lux/data/bool.lux @@ -0,0 +1,47 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monoid + eq + codec) + (codata function))) + +## [Structures] +(struct: #export _ (Eq Bool) + (def: (= x y) + (if x + y + (not y)))) + +(do-template [ ] + [(struct: #export (Monoid Bool) + (def: unit ) + (def: (append x y) + ( x y)))] + + [ Or@Monoid false or] + [And@Monoid true and] + ) + +(struct: #export _ (Codec Text Bool) + (def: (encode x) + (if x + "true" + "false")) + + (def: (decode input) + (case input + "true" (#;Right true) + "false" (#;Right false) + _ (#;Left "Wrong syntax for Bool.")))) + +## [Values] +(def: #export complement + {#;doc "Generates the complement of a predicate. + That is a predicate that returns the oposite of the original predicate."} + (All [a] (-> (-> a Bool) (-> a Bool))) + (. not)) diff --git a/stdlib/source/lux/data/char.lux b/stdlib/source/lux/data/char.lux new file mode 100644 index 000000000..6af987408 --- /dev/null +++ b/stdlib/source/lux/data/char.lux @@ -0,0 +1,107 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux/control eq + [ord] + codec + hash) + (.. [text "Text/" Monoid])) + +## [Structures] +(struct: #export _ (Eq Char) + (def: (= x y) + (_lux_proc ["jvm" "ceq"] [x y]))) + +(struct: #export _ (Hash Char) + (def: eq Eq) + (def: hash + (|>. [] + (_lux_proc ["jvm" "c2i"]) + [] + (_lux_proc ["jvm" "i2l"]) + int-to-nat))) + +(struct: #export _ (ord;Ord Char) + (def: eq Eq) + + (do-template [ ] + [(def: ( test subject) + (_lux_proc ["jvm" ] [subject test]))] + + [< "clt"] + [> "cgt"] + ) + + (do-template [ ] + [(def: ( test subject) + (or (_lux_proc ["jvm" "ceq"] [subject test]) + (_lux_proc ["jvm" ] [subject test])))] + + [<= "clt"] + [>= "cgt"] + )) + +(struct: #export _ (Codec Text Char) + (def: (encode x) + (let [as-text (case x + #"\t" "\\t" + #"\b" "\\b" + #"\n" "\\n" + #"\r" "\\r" + #"\f" "\\f" + #"\"" "\\\"" + #"\\" "\\\\" + _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))] + ($_ Text/append "#\"" as-text "\""))) + + (def: (decode y) + (let [size (text;size y)] + (if (and (text;starts-with? "#\"" y) + (text;ends-with? "\"" y) + (or (=+ +4 size) + (=+ +5 size))) + (if (=+ +4 size) + (case (text;at +2 y) + #;None + (#;Left (Text/append "Wrong syntax for Char: " y)) + + (#;Some char) + (#;Right char)) + (case [(text;at +2 y) (text;at +3 y)] + [(#;Some #"\\") (#;Some char)] + (case char + #"t" (#;Right #"\t") + #"b" (#;Right #"\b") + #"n" (#;Right #"\n") + #"r" (#;Right #"\r") + #"f" (#;Right #"\f") + #"\"" (#;Right #"\"") + #"\\" (#;Right #"\\") + #"t" (#;Right #"\t") + _ (#;Left (Text/append "Wrong syntax for Char: " y))) + + _ + (#;Left (Text/append "Wrong syntax for Char: " y)))) + (#;Left (Text/append "Wrong syntax for Char: " y)))))) + +## [Values] +(def: #export (space? x) + {#;doc "Checks whether the character is white-space."} + (-> Char Bool) + (_lux_proc ["jvm" "invokestatic:java.lang.Character:isWhitespace:char"] [x])) + +(def: #export (as-text x) + (-> Char Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x])) + +(def: #export (char x) + (-> Nat Char) + (_lux_proc ["nat" "to-char"] [x])) + +(def: #export (code x) + (-> Char Nat) + (_lux_proc ["char" "to-nat"] [x])) diff --git a/stdlib/source/lux/data/error.lux b/stdlib/source/lux/data/error.lux new file mode 100644 index 000000000..ce2f529b9 --- /dev/null +++ b/stdlib/source/lux/data/error.lux @@ -0,0 +1,66 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + ["M" monad #*]))) + +## [Types] +(type: #export (Error a) + (Either Text a)) + +## [Structures] +(struct: #export _ (Functor Error) + (def: (map f ma) + (case ma + (#;Left msg) (#;Left msg) + (#;Right datum) (#;Right (f datum))))) + +(struct: #export _ (Applicative Error) + (def: functor Functor) + + (def: (wrap a) + (#;Right a)) + + (def: (apply ff fa) + (case ff + (#;Right f) + (case fa + (#;Right a) + (#;Right (f a)) + + (#;Left msg) + (#;Left msg)) + + (#;Left msg) + (#;Left msg)) + )) + +(struct: #export _ (Monad Error) + (def: applicative Applicative) + + (def: (join mma) + (case mma + (#;Left msg) (#;Left msg) + (#;Right ma) ma))) + +(struct: #export (ErrorT Monad) + (All [M] (-> (Monad M) (Monad (All [a] (M (Error a)))))) + (def: applicative (compA (get@ #M;applicative Monad) Applicative)) + (def: (join MeMea) + (do Monad + [eMea MeMea] + (case eMea + (#;Left error) + (wrap (#;Left error)) + + (#;Right Mea) + (join Mea))))) + +(def: #export (lift-error Monad) + (All [M a] (-> (Monad M) (-> (M a) (M (Error a))))) + (liftM Monad (:: Monad wrap))) diff --git a/stdlib/source/lux/data/error/exception.lux b/stdlib/source/lux/data/error/exception.lux new file mode 100644 index 000000000..be9a09327 --- /dev/null +++ b/stdlib/source/lux/data/error/exception.lux @@ -0,0 +1,62 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad) + (data error + [text]) + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax] + (syntax [common])))) + +## [Types] +(type: #export Exception + (-> Text Text)) + +## [Values] +(def: #hidden _Text/append_ + (-> Text Text Text) + (:: text;Monoid append)) + +(def: #export (catch exception then try) + (All [a] + (-> Exception (-> Text a) (Error a) + (Error a))) + (case try + (#;Right output) + (#;Right output) + + (#;Left error) + (if (text;starts-with? (exception "") error) + (#;Right (then error)) + (#;Left error)))) + +(def: #export (else to-do try) + (All [a] + (-> (-> Text a) (Error a) a)) + (case try + (#;Right output) + output + + (#;Left error) + (to-do error))) + +(def: #export (return value) + (All [a] (-> a (Error a))) + (#;Right value)) + +(def: #export (throw exception message) + (All [a] (-> Exception Text (Error a))) + (#;Left (exception message))) + +(syntax: #export (exception: {_ex-lev common;export-level} {name s;local-symbol}) + (do @ + [current-module compiler;current-module-name + #let [g!message (ast;symbol ["" "message"])]] + (wrap (list (` (def: (~@ (common;gen-export-level _ex-lev)) ((~ (ast;symbol ["" name])) (~ g!message)) + Exception + ($_ _Text/append_ "[" (~ (ast;text current-module)) ";" (~ (ast;text name)) "]\t" (~ g!message)))))))) diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux new file mode 100644 index 000000000..c51e4b04c --- /dev/null +++ b/stdlib/source/lux/data/format/json.lux @@ -0,0 +1,1031 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + monad + eq + codec) + (data [bool] + [text "Text/" Eq Monoid] + text/format + [number #* "Real/" Codec] + maybe + [char "Char/" Eq Codec] + error + [sum] + [product] + (struct [list "" Fold "List/" Monad] + [vector #+ Vector vector "Vector/" Monad] + [dict #+ Dict])) + (codata [function]) + [compiler #+ Monad with-gensyms] + (macro [syntax #+ syntax:] + [ast] + [poly #+ poly:]) + [type] + [lexer #+ Lexer Monad])) + +## [Types] +(do-template [ ] + [(type: #export )] + + [Null Unit] + [Boolean Bool] + [Number Real] + [String Text] + ) + +(type: #export #rec JSON + (#Null Null) + (#Boolean Boolean) + (#Number Number) + (#String String) + (#Array (Vector JSON)) + (#Object (Dict String JSON))) + +(do-template [ ] + [(type: #export )] + + [Array (Vector JSON)] + [Object (Dict String JSON)] + ) + +(type: #export (Parser a) + (-> JSON (Error a))) + +(type: #export (Gen a) + (-> a JSON)) + +## [Syntax] +(syntax: #export (json token) + (let [(^open) Monad + wrapper (lambda [x] (` (;;json (~ x))))] + (case token + (^template [ ] + [_ ( value)] + (wrap (list (` (: JSON ( (~ ( value)))))))) + ([#;BoolS ast;bool #Boolean] + [#;IntS (|>. int-to-real ast;real) #Number] + [#;RealS ast;real #Number] + [#;TextS ast;text #String]) + + [_ (#;TagS ["" "null"])] + (wrap (list (` (: JSON #Null)))) + + [_ (#;TupleS members)] + (wrap (list (` (: JSON (#Array (vector (~@ (List/map wrapper members)))))))) + + [_ (#;RecordS pairs)] + (do Monad + [pairs' (mapM @ + (lambda [[slot value]] + (case slot + [_ (#;TextS key-name)] + (wrap (` [(~ (ast;text key-name)) (~ (wrapper value))])) + + _ + (compiler;fail "Wrong syntax for JSON object."))) + pairs)] + (wrap (list (` (: JSON (#Object (dict;from-list text;Hash (list (~@ pairs'))))))))) + + _ + (wrap (list token)) + ))) + +## [Values] +(def: #hidden (show-null _) (-> Null Text) "null") +(do-template [ ] + [(def: (-> Text) (:: encode))] + + [show-boolean Boolean bool;Codec] + [show-number Number number;Codec] + [show-string String text;Codec]) + +(def: (show-array show-json elems) + (-> (-> JSON Text) (-> Array Text)) + (format "[" + (|> elems (Vector/map show-json) vector;vector-to-list (text;join-with ",")) + "]")) + +(def: (show-object show-json object) + (-> (-> JSON Text) (-> Object Text)) + (format "{" + (|> object + dict;entries + (List/map (lambda [[key value]] (format (:: text;Codec encode key) ":" (show-json value)))) + (text;join-with ",")) + "}")) + +(def: (show-json json) + (-> JSON Text) + (case json + (^template [ ] + ( value) + ( value)) + ([#Null show-null] + [#Boolean show-boolean] + [#Number show-number] + [#String show-string] + [#Array (show-array show-json)] + [#Object (show-object show-json)]) + )) + +(def: #export null + JSON + #Null) + +(def: #export (keys json) + (-> JSON (Error (List String))) + (case json + (#Object obj) + (#;Right (dict;keys obj)) + + _ + (#;Left (format "Can't get keys of a non-object.")))) + +(def: #export (get key json) + (-> String JSON (Error JSON)) + (case json + (#Object obj) + (case (dict;get key obj) + (#;Some value) + (#;Right value) + + #;None + (#;Left (format "Missing field " (show-string key) " on object."))) + + _ + (#;Left (format "Can't get field " (show-string key) " of a non-object.")))) + +(def: #export (set key value json) + (-> String JSON JSON (Error JSON)) + (case json + (#Object obj) + (#;Right (#Object (dict;put key value obj))) + + _ + (#;Left (format "Can't set field " (show-string key) " of a non-object.")))) + +(do-template [ ] + [(def: #export ( key json) + (-> Text JSON (Error )) + (case (get key json) + (#;Right ( value)) + (#;Right value) + + (#;Right _) + (#;Left (format "Wrong value type at key " (show-string key))) + + (#;Left error) + (#;Left error)))] + + [get-boolean #Boolean Boolean] + [get-number #Number Number] + [get-string #String String] + [get-array #Array Array] + [get-object #Object Object] + ) + +(do-template [ ] + [(def: #export ( value) + (Gen ) + ( value))] + + [gen-boolean Boolean #Boolean] + [gen-number Number #Number] + [gen-string String #String] + [gen-array Array #Array] + [gen-object Object #Object] + ) + +(def: #export (gen-nullable gen) + (All [a] (-> (Gen a) (Gen (Maybe a)))) + (lambda [elem] + (case elem + #;None #Null + (#;Some value) (gen value)))) + +## Lexers +(def: space~ + (Lexer Text) + (lexer;some' lexer;space)) + +(def: data-sep + (Lexer [Text Char Text]) + ($_ lexer;seq space~ (lexer;this-char #",") space~)) + +(def: null~ + (Lexer Null) + (do Monad + [_ (lexer;this "null")] + (wrap []))) + +(do-template [ ] + [(def: + (Lexer Boolean) + (do Monad + [_ (lexer;this )] + (wrap )))] + + [t~ "true" true] + [f~ "false" false] + ) + +(def: boolean~ + (Lexer Boolean) + (lexer;either t~ f~)) + +(def: number~ + (Lexer Number) + (do Monad + [?sign (: (Lexer (Maybe Text)) + (lexer;opt (lexer;this "-"))) + digits (: (Lexer Text) + (lexer;many' lexer;digit)) + ?decimals (: (Lexer (Maybe Text)) + (lexer;opt (do @ + [_ (lexer;this ".")] + (lexer;many' lexer;digit))))] + (case (: (Error Real) + (Real/decode (format (default "" ?sign) + digits "." + (default "0" ?decimals)))) + (#;Left message) + (lexer;fail message) + + (#;Right value) + (wrap value)))) + +(def: (un-escape escaped) + (-> Char Text) + (case escaped + #"t" "\t" + #"b" "\b" + #"n" "\n" + #"r" "\r" + #"f" "\f" + #"\"" "\"" + #"\\" "\\" + _ "")) + +(def: string-body~ + (Lexer Text) + (loop [_ []] + (do Monad + [chars (lexer;some' (lexer;none-of "\\\"")) + stop-char lexer;peek] + (if (Char/= #"\\" stop-char) + (do @ + [_ lexer;any + escaped lexer;any + next-chars (recur [])] + (wrap (format chars (un-escape escaped) next-chars))) + (wrap chars))))) + +(def: string~ + (Lexer String) + (do Monad + [_ (lexer;this "\"") + string-body string-body~ + _ (lexer;this "\"")] + (wrap string-body))) + +(def: (kv~ json~) + (-> (-> Unit (Lexer JSON)) (Lexer [String JSON])) + (do Monad + [key string~ + _ space~ + _ (lexer;this-char #":") + _ space~ + value (json~ [])] + (wrap [key value]))) + +(do-template [ ] + [(def: ( json~) + (-> (-> Unit (Lexer JSON)) (Lexer )) + (do Monad + [_ (lexer;this-char ) + _ space~ + elems (lexer;sep-by data-sep ) + _ space~ + _ (lexer;this-char )] + (wrap ( elems))))] + + [array~ Array #"[" #"]" (json~ []) vector;list-to-vector] + [object~ Object #"{" #"}" (kv~ json~) (dict;from-list text;Hash)] + ) + +(def: (json~' _) + (-> Unit (Lexer JSON)) + ($_ lexer;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~'))) + +## [Structures] +(struct: #export _ (Functor Parser) + (def: (map f ma) + (lambda [json] + (case (ma json) + (#;Left msg) + (#;Left msg) + + (#;Right a) + (#;Right (f a)))))) + +(struct: #export _ (Applicative Parser) + (def: functor Functor) + + (def: (wrap x json) + (#;Right x)) + + (def: (apply ff fa) + (lambda [json] + (case (ff json) + (#;Right f) + (case (fa json) + (#;Right a) + (#;Right (f a)) + + (#;Left msg) + (#;Left msg)) + + (#;Left msg) + (#;Left msg))))) + +(struct: #export _ (Monad Parser) + (def: applicative Applicative) + + (def: (join mma) + (lambda [json] + (case (mma json) + (#;Left msg) + (#;Left msg) + + (#;Right ma) + (ma json))))) + +## [Values] +## Syntax +(do-template [ 
]
+  [(def: #export ( json)
+     (Parser )
+     (case json
+       ( value)
+       (#;Right (
 value))
+
+       _
+       (#;Left (format "JSON value is not a "  ": " (show-json json)))))]
+
+  [unit Unit #Null    "null"    id]
+  [bool Bool #Boolean "boolean" id]
+  [int  Int  #Number  "number"  real-to-int]
+  [real Real #Number  "number"  id]
+  [text Text #String  "string"  id]
+  )
+
+(do-template [       
]
+  [(def: #export ( test json)
+     (->  (Parser Bool))
+     (case json
+       ( value)
+       (#;Right (::  = test (
 value)))
+
+       _
+       (#;Left (format "JSON value is not a "  ": " (show-json json)))))
+
+   (def: #export ( test json)
+     (->  (Parser Unit))
+     (case json
+       ( value)
+       (let [value (
 value)]
+         (if (::  = test value)
+           (#;Right [])
+           (#;Left (format "Value mismatch: "
+                           (::  encode test) "=/=" (::  encode value)))))
+
+       _
+       (#;Left (format "JSON value is not a "  ": " (show-json json)))))]
+
+  [bool? bool! Bool bool;Eq   bool;Codec   #Boolean "boolean" id]
+  [int?  int!  Int  number;Eq  number;Codec  #Number  "number"  real-to-int]
+  [real? real! Real number;Eq number;Codec #Number  "number"  id]
+  [text? text! Text text;Eq   text;Codec   #String  "string"  id]
+  )
+
+(def: #export (char json)
+  (Parser Char)
+  (case json
+    (#String input)
+    (case (Char/decode (format "#\"" input "\""))
+      (#;Right value)
+      (#;Right value)
+
+      (#;Left _)
+      (#;Left (format "Invalid format for char: " input)))
+
+    _
+    (#;Left (format "JSON value is not a " "string" ": " (show-json json)))))
+
+(def: #export (char? test json)
+  (-> Char (Parser Bool))
+  (case json
+    (#String input)
+    (case (Char/decode (format "#\"" input "\""))
+      (#;Right value)
+      (if (:: char;Eq = test value)
+        (#;Right true)
+        (#;Left (format "Value mismatch: "
+                        (:: char;Codec encode test) "=/=" (:: char;Codec encode value))))
+
+      (#;Left _)
+      (#;Left (format "Invalid format for char: " input)))
+
+    _
+    (#;Left (format "JSON value is not a " "string" ": " (show-json json)))))
+
+(def: #export (char! test json)
+  (-> Char (Parser Unit))
+  (case json
+    (#String input)
+    (case (Char/decode (format "#\"" input "\""))
+      (#;Right value)
+      (if (:: char;Eq = test value)
+        (#;Right [])
+        (#;Left (format "Value mismatch: "
+                        (:: char;Codec encode test) "=/=" (:: char;Codec encode value))))
+
+      (#;Left _)
+      (#;Left (format "Invalid format for char: " input)))
+
+    _
+    (#;Left (format "JSON value is not a " "string" ": " (show-json json)))))
+
+(def: #export (nullable parser)
+  (All [a] (-> (Parser a) (Parser (Maybe a))))
+  (lambda [json]
+    (case json
+      #Null
+      (#;Right #;None)
+      
+      _
+      (case (parser json)
+        (#;Left error)
+        (#;Left error)
+
+        (#;Right value)
+        (#;Right (#;Some value)))
+      )))
+
+(def: #export (array parser)
+  (All [a] (-> (Parser a) (Parser (List a))))
+  (lambda [json]
+    (case json
+      (#Array values)
+      (do Monad
+        [elems (mapM @ parser (vector;vector-to-list values))]
+        (wrap elems))
+
+      _
+      (#;Left (format "JSON value is not an array: " (show-json json))))))
+
+(def: #export (object parser)
+  (All [a] (-> (Parser a) (Parser (Dict String a))))
+  (lambda [json]
+    (case json
+      (#Object fields)
+      (do Monad
+        [kvs (mapM @
+                   (lambda [[key val']]
+                     (do @
+                       [val (parser val')]
+                       (wrap [key val])))
+                   (dict;entries fields))]
+        (wrap (dict;from-list text;Hash kvs)))
+
+      _
+      (#;Left (format "JSON value is not an object: " (show-json json))))))
+
+(def: #export (at idx parser)
+  (All [a] (-> Nat (Parser a) (Parser a)))
+  (lambda [json]
+    (case json
+      (#Array values)
+      (case (vector;at idx values)
+        (#;Some value)
+        (case (parser value)
+          (#;Right output)
+          (#;Right output)
+
+          (#;Left error)
+          (#;Left (format "JSON array index [" (%n idx) "]: (" error ") @ " (show-json json))))
+
+        #;None
+        (#;Left (format "JSON array does not have index " (%n idx) " @ " (show-json json))))
+      
+      _
+      (#;Left (format "JSON value is not an array: " (show-json json))))))
+
+(def: #export (field field-name parser)
+  (All [a] (-> Text (Parser a) (Parser a)))
+  (lambda [json]
+    (case (get field-name json)
+      (#;Some value)
+      (case (parser value)
+        (#;Right output)
+        (#;Right output)
+
+        (#;Left error)
+        (#;Left (format "Failed to get JSON object field " (show-string field-name) ": (" error ") @ " (show-json json))))
+
+      (#;Left _)
+      (#;Left (format "JSON object does not have field " (show-string field-name) " @ " (show-json json))))))
+
+(def: #export any
+  (Parser JSON)
+  (lambda [json]
+    (#;Right json)))
+
+(def: #export (seq pa pb)
+  (All [a b] (-> (Parser a) (Parser b) (Parser [a b])))
+  (do Monad
+    [=a pa
+     =b pb]
+    (wrap [=a =b])))
+
+(def: #export (alt pa pb json)
+  (All [a b] (-> (Parser a) (Parser b) (Parser (| a b))))
+  (case (pa json)
+    (#;Right a)
+    (sum;right (sum;left a))
+
+    (#;Left message0)
+    (case (pb json)
+      (#;Right b)
+      (sum;right (sum;right b))
+
+      (#;Left message1)
+      (#;Left message0))))
+
+(def: #export (either pl pr json)
+  (All [a] (-> (Parser a) (Parser a) (Parser a)))
+  (case (pl json)
+    (#;Right x)
+    (#;Right x)
+
+    _
+    (pr json)))
+
+(def: #export (opt p json)
+  (All [a]
+    (-> (Parser a) (Parser (Maybe a))))
+  (case (p json)
+    (#;Left _)  (#;Right #;None)
+    (#;Right x) (#;Right (#;Some x))))
+
+(def: #export (run parser json)
+  (All [a] (-> (Parser a) JSON (Error a)))
+  (parser json))
+
+(def: #export (ensure test parser json)
+  (All [a] (-> (Parser Unit) (Parser a) (Parser a)))
+  (case (test json)
+    (#;Right _)
+    (parser json)
+
+    (#;Left error)
+    (#;Left error)))
+
+(def: #export (array-size! array-size json)
+  (-> Nat (Parser Unit))
+  (case json
+    (#Array parts)
+    (if (=+ array-size (vector;size parts))
+      (#;Right [])
+      (#;Left (format "JSON array does no have size " (%n array-size) " " (show-json json))))
+
+    _
+    (#;Left (format "JSON value is not an array: " (show-json json)))))
+
+(def: #export (object-fields! wanted-fields json)
+  (-> (List String) (Parser Unit))
+  (case json
+    (#Object kvs)
+    (let [actual-fields (dict;keys kvs)]
+      (if (and (=+ (list;size wanted-fields) (list;size actual-fields))
+               (list;every? (list;member? text;Eq wanted-fields)
+                            actual-fields))
+        (#;Right [])
+        (#;Left (format "JSON object has wrong field-set. Expected: [" (text;join-with ", " wanted-fields) "]. Actual: [" (text;join-with ", " actual-fields) "]"))))
+
+    _
+    (#;Left (format "JSON value is not an object: " (show-json json)))))
+
+## [Structures]
+(struct: #export _ (Eq JSON)
+  (def: (= x y)
+    (case [x y]
+      [#Null #Null]
+      true
+
+      (^template [ ]
+                 [( x') ( y')]
+                 (::  = x' y'))
+      ([#Boolean bool;Eq]
+       [#Number  number;Eq]
+       [#String  text;Eq])
+
+      [(#Array xs) (#Array ys)]
+      (and (=+ (vector;size xs) (vector;size ys))
+           (fold (lambda [idx prev]
+                   (and prev
+                        (default false
+                          (do Monad
+                            [x' (vector;at idx xs)
+                             y' (vector;at idx ys)]
+                            (wrap (= x' y'))))))
+                 true
+                 (list;indices (vector;size xs))))
+      
+      [(#Object xs) (#Object ys)]
+      (and (=+ (dict;size xs) (dict;size ys))
+           (fold (lambda [[xk xv] prev]
+                   (and prev
+                        (case (dict;get xk ys)
+                          #;None   false
+                          (#;Some yv) (= xv yv))))
+                 true
+                 (dict;entries xs)))
+      
+      _
+      false)))
+
+(struct: #export _ (Codec Text JSON)
+  (def: encode show-json)
+  (def: decode (lexer;run (json~' []))))
+
+## [Syntax]
+(type: Shape
+  (#ArrayShape (List AST))
+  (#ObjectShape (List [Text AST])))
+
+(def: _shape^
+  (syntax;Syntax Shape)
+  (syntax;alt (syntax;tuple (syntax;some syntax;any))
+              (syntax;record (syntax;some (syntax;seq syntax;text syntax;any)))))
+
+(syntax: #export (shape^ {shape _shape^})
+  (case shape
+    (#ArrayShape parts)
+    (let [array-size (list;size parts)
+          parsers (|> parts
+                      (list;zip2 (list;indices array-size))
+                      (List/map (lambda [[idx parser]]
+                                  (` (at (~ (ast;nat idx)) (~ parser))))))]
+      (wrap (list (` ($_ seq (~@ parsers))))))
+
+    (#ObjectShape kvs)
+    (let [fields (List/map product;left kvs)
+          parsers (List/map (lambda [[field-name parser]]
+                              (` (field (~ (ast;text field-name)) (~ parser))))
+                            kvs)]
+      (wrap (list (` ($_ seq (~@ parsers))))))
+    ))
+
+(syntax: #export (shape!^ {shape _shape^})
+  (case shape
+    (#ArrayShape parts)
+    (let [array-size (list;size parts)
+          parsers (|> parts
+                      (list;zip2 (list;indices array-size))
+                      (List/map (lambda [[idx parser]]
+                                  (` (at (~ (ast;nat idx)) (~ parser))))))]
+      (wrap (list (` (ensure (array-size! (~ (ast;nat array-size)))
+                             ($_ seq (~@ parsers)))))))
+
+    (#ObjectShape kvs)
+    (let [fields (List/map product;left kvs)
+          parsers (List/map (lambda [[field-name parser]]
+                              (` (field (~ (ast;text field-name)) (~ parser))))
+                            kvs)]
+      (wrap (list (` (ensure (object-fields! (list (~@ (List/map ast;text fields))))
+                             ($_ seq (~@ parsers)))))))
+    ))
+
+## [Polytypism]
+(def: #hidden _map_
+  (All [a b] (-> (-> a b) (List a) (List b)))
+  List/map)
+
+(poly: #export (|Codec@JSON//encode| *env* :x:)
+  (let [->Codec//encode (: (-> AST AST)
+                           (lambda [.type.] (` (-> (~ .type.) JSON))))]
+    (let% [ (do-template [  ]
+                     [(do @ [_ ( :x:)] (wrap (` (: (~ (->Codec//encode (` ))) ))))]
+
+                     [Unit poly;unit (lambda [(~ (ast;symbol ["" "0"]))] #Null)]
+                     [Bool poly;bool ;;boolean]
+                     [Int  poly;int  (|>. int-to-real ;;number)]
+                     [Real poly;real ;;number]
+                     [Char poly;char (|>. char;->Text ;;string)]
+                     [Text poly;text ;;string])]
+      ($_ compiler;either
+          
+          (with-gensyms [g!type-fun g!case g!input g!key g!val]
+            (do @
+              [:sub: (poly;list :x:)
+               [g!vars members] (poly;tuple :sub:)
+               :val: (case members
+                       (^ (list :key: :val:))
+                       (do @ [_ (poly;text :key:)]
+                         (wrap :val:))
+
+                       _
+                       (compiler;fail ""))
+               #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+               .val. (|Codec@JSON//encode| new-*env* :val:)
+               #let [:x:+ (case g!vars
+                            #;Nil
+                            (->Codec//encode (type;type-to-ast :x:))
+
+                            _
+                            (` (All (~ g!type-fun) [(~@ g!vars)]
+                                 (-> (~@ (List/map ->Codec//encode g!vars))
+                                     (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+              (wrap (` (: (~ :x:+)
+                          (lambda [(~@ g!vars) (~ g!input)]
+                            (|> (~ g!input)
+                                (_map_ (: (-> [Text (~ (type;type-to-ast :val:))]
+                                              [Text JSON])
+                                          (lambda [[(~ g!key) (~ g!val)]]
+                                            [(~ g!key)
+                                             ((~ .val.) (~ g!val))])))
+                                ;;object))
+                          )))
+              ))
+          (do @
+            [:sub: (poly;maybe :x:)
+             .sub. (|Codec@JSON//encode| *env* :sub:)]
+            (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+                        (;;nullable (~ .sub.))))))
+          (do @
+            [:sub: (poly;list :x:)
+             .sub. (|Codec@JSON//encode| *env* :sub:)]
+            (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+                        (|>. (_map_ (~ .sub.)) vector;list-to-vector ;;array)))))
+          (with-gensyms [g!type-fun g!case g!input]
+            (do @
+              [[g!vars cases] (poly;variant :x:)
+               #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+               pattern-matching (mapM @
+                                      (lambda [[name :case:]]
+                                        (do @
+                                          [#let [tag (ast;tag name)]
+                                           encoder (|Codec@JSON//encode| new-*env* :case:)]
+                                          (wrap (list (` ((~ tag) (~ g!case)))
+                                                      (` (;;json [(~ (ast;text (product;right name)))
+                                                                  ((~ encoder) (~ g!case))]))))))
+                                      cases)
+               #let [:x:+ (case g!vars
+                            #;Nil
+                            (->Codec//encode (type;type-to-ast :x:))
+
+                            _
+                            (` (All (~ g!type-fun) [(~@ g!vars)]
+                                 (-> (~@ (List/map ->Codec//encode g!vars))
+                                     (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+              (wrap (` (: (~ :x:+)
+                          (lambda [(~@ g!vars) (~ g!input)]
+                            (case (~ g!input)
+                              (~@ (List/join pattern-matching))))
+                          )))))
+          (with-gensyms [g!type-fun g!case g!input]
+            (do @
+              [[g!vars slots] (poly;record :x:)
+               #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+               synthesis (mapM @
+                               (lambda [[name :slot:]]
+                                 (do @
+                                   [encoder (|Codec@JSON//encode| new-*env* :slot:)]
+                                   (wrap [(` (~ (ast;text (product;right name))))
+                                          (` ((~ encoder) (get@ (~ (ast;tag name)) (~ g!input))))])))
+                               slots)
+               #let [:x:+ (case g!vars
+                            #;Nil
+                            (->Codec//encode (type;type-to-ast :x:))
+
+                            _
+                            (` (All (~ g!type-fun) [(~@ g!vars)]
+                                 (-> (~@ (List/map ->Codec//encode g!vars))
+                                     (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+              (wrap (` (: (~ :x:+)
+                          (lambda [(~@ g!vars) (~ g!input)]
+                            (;;json (~ (ast;record synthesis))))
+                          )))))
+          (with-gensyms [g!type-fun g!case g!input]
+            (do @
+              [[g!vars members] (poly;tuple :x:)
+               #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+               pattern-matching (mapM @
+                                      (lambda [:member:]
+                                        (do @
+                                          [g!member (compiler;gensym "g!member")
+                                           encoder (|Codec@JSON//encode| new-*env* :member:)]
+                                          (wrap [g!member encoder])))
+                                      members)
+               #let [:x:+ (case g!vars
+                            #;Nil
+                            (->Codec//encode (type;type-to-ast :x:))
+
+                            _
+                            (` (All (~ g!type-fun) [(~@ g!vars)]
+                                 (-> (~@ (List/map ->Codec//encode g!vars))
+                                     (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]
+               #let [.tuple. (` [(~@ (List/map product;left pattern-matching))])]]
+              (wrap (` (: (~ :x:+)
+                          (lambda [(~@ g!vars) (~ g!input)]
+                            (case (~ g!input)
+                              (~ .tuple.)
+                              (;;array (list (~@ (List/map (lambda [[g!member g!encoder]]
+                                                             (` ((~ g!encoder) (~ g!member))))
+                                                           pattern-matching))))))
+                          )))
+              ))
+          (do @
+            [[:func: :args:] (poly;apply :x:)
+             .func. (|Codec@JSON//encode| *env* :func:)
+             .args. (mapM @ (|Codec@JSON//encode| *env*) :args:)]
+            (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+                        ((~ .func.) (~@ .args.))))))
+          (poly;bound *env* :x:)
+          (compiler;fail (format "Can't create JSON encoder for: " (type;type-to-text :x:)))
+          ))))
+
+(poly: #export (Codec//decode *env* :x:)
+  (let [->Codec//decode (: (-> AST AST)
+                           (lambda [.type.] (` (-> JSON (Error (~ .type.))))))]
+    (let% [ (do-template [  ]
+                     [(do @ [_ ( :x:)] (wrap (` (: (~ (->Codec//decode (` ))) ))))]
+
+                     [Unit poly;unit ;;null]
+                     [Bool poly;bool ;;bool]
+                     [Int  poly;int  ;;int]
+                     [Real poly;real ;;real]
+                     [Char poly;char ;;char]
+                     [Text poly;text ;;text])
+            (do-template [  ]
+                       [(do @
+                          [:sub: ( :x:)
+                           .sub. (Codec//decode *env* :sub:)]
+                          (wrap (` (: (~ (->Codec//decode (type;type-to-ast :x:)))
+                                      ( (~ .sub.))))))]
+
+                       [Maybe poly;maybe ;;nullable]
+                       [List  poly;list  ;;array])]
+      ($_ compiler;either
+          
+          (with-gensyms [g!type-fun g!case g!input g!key g!val]
+            (do @
+              [:sub: (poly;list :x:)
+               [g!vars members] (poly;tuple :sub:)
+               :val: (case members
+                       (^ (list :key: :val:))
+                       (do @ [_ (poly;text :key:)]
+                         (wrap :val:))
+
+                       _
+                       (compiler;fail ""))
+               #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+               .val. (Codec//decode new-*env* :val:)
+               #let [:x:+ (case g!vars
+                            #;Nil
+                            (->Codec//decode (type;type-to-ast :x:))
+
+                            _
+                            (` (All (~ g!type-fun) [(~@ g!vars)]
+                                 (-> (~@ (List/map ->Codec//decode g!vars))
+                                     (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+              (wrap (` (: (~ :x:+)
+                          (lambda [(~@ g!vars) (~ g!input)]
+                            (do Monad
+                              [(~ g!key) (;;keys (~ g!input))]
+                              (mapM (~ (' %))
+                                    (lambda [(~ g!key)]
+                                      (do Monad
+                                        [(~ g!val) (;;get (~ g!key) (~ g!input))
+                                         (~ g!val) (;;run (~ .val.) (~ g!val))]
+                                        ((~ (' wrap)) [(~ g!key) (~ g!val)])))
+                                    (~ g!key))))
+                          )))
+              ))
+          
+          (with-gensyms [g!type-fun g!_]
+            (do @
+              [[g!vars cases] (poly;variant :x:)
+               #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+               pattern-matching (mapM @
+                                      (lambda [[name :case:]]
+                                        (do @
+                                          [#let [tag (ast;tag name)]
+                                           decoder (Codec//decode new-*env* :case:)]
+                                          (wrap (list (` (do Monad
+                                                           [(~ g!_) (;;at 0 (;;text! (~ (ast;text (product;right name)))))
+                                                            (~ g!_) (;;at 1 (~ decoder))]
+                                                           ((~ (' wrap)) ((~ tag) (~ g!_)))))))))
+                                      cases)
+               #let [:x:+ (case g!vars
+                            #;Nil
+                            (->Codec//decode (type;type-to-ast :x:))
+
+                            _
+                            (` (All (~ g!type-fun) [(~@ g!vars)]
+                                 (-> (~@ (List/map ->Codec//decode g!vars))
+                                     (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))
+                     base-parser (` ($_ ;;either
+                                        (~@ (List/join pattern-matching))))
+                     parser (case g!vars
+                              #;Nil
+                              base-parser
+
+                              _
+                              (` (lambda [(~@ g!vars)] (~ base-parser))))]]
+              (wrap (` (: (~ :x:+) (~ parser))))
+              ))
+          (with-gensyms [g!type-fun g!case g!input]
+            (do @
+              [[g!vars slots] (poly;record :x:)
+               #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+               extraction (mapM @
+                                (lambda [[name :slot:]]
+                                  (do @
+                                    [#let [g!member (ast;symbol ["" (product;right name)])]
+                                     decoder (Codec//decode new-*env* :slot:)]
+                                    (wrap (list g!member
+                                                (` (;;get (~ (ast;text (product;right name))) (~ g!input)))
+                                                g!member
+                                                (` ((~ decoder) (~ g!member)))))))
+                                slots)
+               #let [:x:+ (case g!vars
+                            #;Nil
+                            (->Codec//decode (type;type-to-ast :x:))
+
+                            _
+                            (` (All (~ g!type-fun) [(~@ g!vars)]
+                                 (-> (~@ (List/map ->Codec//decode g!vars))
+                                     (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+              (wrap (` (: (~ :x:+)
+                          (lambda [(~@ g!vars) (~ g!input)]
+                            (do Monad
+                              [(~@ (List/join extraction))]
+                              ((~ (' wrap)) (~ (ast;record (List/map (lambda [[name :slot:]]
+                                                                       [(ast;tag name) (ast;symbol ["" (product;right name)])])
+                                                                     slots))))))
+                          )))))
+          (with-gensyms [g!type-fun g!case g!input]
+            (do @
+              [[g!vars members] (poly;tuple :x:)
+               #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+               pattern-matching (mapM @
+                                      (lambda [:member:]
+                                        (do @
+                                          [g!member (compiler;gensym "g!member")
+                                           decoder (Codec//decode new-*env* :member:)]
+                                          (wrap [g!member decoder])))
+                                      members)
+               #let [:x:+ (case g!vars
+                            #;Nil
+                            (->Codec//decode (type;type-to-ast :x:))
+
+                            _
+                            (` (All (~ g!type-fun) [(~@ g!vars)]
+                                 (-> (~@ (List/map ->Codec//decode g!vars))
+                                     (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]
+               #let [.decoder. (case g!vars
+                                 #;Nil
+                                 (` (;;shape^ [(~@ (List/map product;right pattern-matching))]))
+
+                                 _
+                                 (` (lambda [(~@ g!vars)]
+                                      (;;shape^ [(~@ (List/map product;right pattern-matching))]))))]]
+              (wrap (` (: (~ :x:+) (~ .decoder.))))
+              ))
+          (do @
+            [[:func: :args:] (poly;apply :x:)
+             .func. (Codec//decode *env* :func:)
+             .args. (mapM @ (Codec//decode *env*) :args:)]
+            (wrap (` (: (~ (->Codec//decode (type;type-to-ast :x:)))
+                        ((~ .func.) (~@ .args.))))))
+          (do @
+            [g!bound (poly;bound *env* :x:)]
+            (wrap g!bound))
+          (compiler;fail (format "Can't create JSON decoder for: " (type;type-to-text :x:)))
+          ))))
+
+(syntax: #export (Codec :x:)
+  (wrap (list (` (: (Codec JSON (~ :x:))
+                    (struct
+                     (def: (~ (' encode)) (|Codec@JSON//encode| (~ :x:)))
+                     (def: (~ (' decode)) (Codec//decode (~ :x:)))
+                     ))))))
diff --git a/stdlib/source/lux/data/ident.lux b/stdlib/source/lux/data/ident.lux
new file mode 100644
index 000000000..4f85da77d
--- /dev/null
+++ b/stdlib/source/lux/data/ident.lux
@@ -0,0 +1,57 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control eq
+                codec
+                hash)
+       (data [text "Text/" Monoid Eq])))
+
+## [Types]
+## (type: Ident
+##   [Text Text])
+
+## [Functions]
+(do-template [ ]
+  [(def: #export ( [module name])
+     (-> Ident Text)
+     )]
+
+  [module module]
+  [name   name]
+  )
+
+## [Structures]
+(struct: #export _ (Eq Ident)
+  (def: (= [xmodule xname] [ymodule yname])
+    (and (Text/= xmodule ymodule)
+         (Text/= xname yname))))
+
+(struct: #export _ (Codec Text Ident)
+  (def: (encode [module name])
+    (case module
+      "" name
+      _ ($_ Text/append module ";" name)))
+  
+  (def: (decode input)
+    (if (Text/= "" input)
+      (#;Left (Text/append "Invalid format for Ident: " input))
+      (case (text;split-all-with ";" input)
+        (^ (list name))
+        (#;Right ["" name])
+
+        (^ (list module name))
+        (#;Right [module name])
+
+        _
+        (#;Left (Text/append "Invalid format for Ident: " input))))))
+
+(struct: #export _ (Hash Ident)
+  (def: eq Eq)
+  
+  (def: (hash [module name])
+    (let [(^open) text;Hash]
+      (*+ (hash module) (hash name)))))
diff --git a/stdlib/source/lux/data/identity.lux b/stdlib/source/lux/data/identity.lux
new file mode 100644
index 000000000..c986db0c0
--- /dev/null
+++ b/stdlib/source/lux/data/identity.lux
@@ -0,0 +1,37 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux/control (functor #as F #refer #all)
+               (applicative #as A #refer #all)
+               (monad #as M #refer #all)
+               (comonad #as CM #refer #all)))
+
+## [Types]
+(type: #export (Identity a)
+  a)
+
+## [Structures]
+(struct: #export _ (Functor Identity)
+  (def: map id))
+
+(struct: #export _ (Applicative Identity)
+  (def: functor Functor)
+
+  (def: wrap id)
+
+  (def: (apply ff fa)
+    (ff fa)))
+
+(struct: #export _ (Monad Identity)
+  (def: applicative Applicative)
+  
+  (def: join id))
+
+(struct: #export _ (CoMonad Identity)
+  (def: functor Functor)
+  (def: unwrap id)
+  (def: split id))
diff --git a/stdlib/source/lux/data/log.lux b/stdlib/source/lux/data/log.lux
new file mode 100644
index 000000000..9e6be6d56
--- /dev/null
+++ b/stdlib/source/lux/data/log.lux
@@ -0,0 +1,62 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux/control monoid
+               ["A" applicative #*]
+               functor
+               ["M" monad #*]))
+
+(type: #export (Log l a)
+  [l a])
+
+(struct: #export Functor (All [l]
+                                (Functor (Log l)))
+  (def: (map f fa)
+    (let [[log datum] fa]
+      [log (f datum)])))
+
+(struct: #export (Applicative mon) (All [l]
+                                          (-> (Monoid l) (Applicative (Log l))))
+  (def: functor Functor)
+
+  (def: (wrap x)
+    [(:: mon unit) x])
+
+  (def: (apply ff fa)
+    (let [[log1 f] ff
+          [log2 a] fa]
+      [(:: mon append log1 log2) (f a)])))
+
+(struct: #export (Monad mon) (All [l]
+                                    (-> (Monoid l) (Monad (Log l))))
+  (def: applicative (Applicative mon))
+
+  (def: (join mma)
+    (let [[log1 [log2 a]] mma]
+      [(:: mon append log1 log2) a])))
+
+(def: #export (log l)
+  (All [l] (-> l (Log l Unit)))
+  [l []])
+
+(struct: #export (LogT Monoid Monad)
+  (All [l M] (-> (Monoid l) (Monad M) (Monad (All [a] (M (Log l a))))))
+  (def: applicative (A;compA (get@ #M;applicative Monad) (Applicative Monoid)))
+  (def: (join MlMla)
+    (do Monad
+      [[l1 Mla] (: (($ 1) (Log ($ 0) (($ 1) (Log ($ 0) ($ 2)))))
+                   MlMla)
+       [l2 a] (: (($ 1) (Log ($ 0) ($ 2)))
+                 Mla)]
+      (wrap [(:: Monoid append l1 l2) a]))))
+
+(def: #export (lift-log Monoid Monad)
+  (All [l M a] (-> (Monoid l) (Monad M) (-> (M a) (M (Log l a)))))
+  (lambda [ma]
+    (do Monad
+      [a ma]
+      (wrap [(:: Monoid unit) a]))))
diff --git a/stdlib/source/lux/data/maybe.lux b/stdlib/source/lux/data/maybe.lux
new file mode 100644
index 000000000..16aa9e30a
--- /dev/null
+++ b/stdlib/source/lux/data/maybe.lux
@@ -0,0 +1,82 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control (monoid #as m #refer #all)
+                (functor #as F #refer #all)
+                (applicative #as A #refer #all)
+                (monad #as M #refer #all)
+                eq)))
+
+## [Types]
+## (type: (Maybe a)
+##   #;None
+##   (#;Some a))
+
+## [Structures]
+(struct: #export Monoid (All [a] (Monoid (Maybe a)))
+  (def: unit #;None)
+  (def: (append xs ys)
+    (case xs
+      #;None     ys
+      (#;Some x) (#;Some x))))
+
+(struct: #export _ (Functor Maybe)
+  (def: (map f ma)
+    (case ma
+      #;None     #;None
+      (#;Some a) (#;Some (f a)))))
+
+(struct: #export _ (Applicative Maybe)
+  (def: functor Functor)
+
+  (def: (wrap x)
+    (#;Some x))
+
+  (def: (apply ff fa)
+    (case [ff fa]
+      [(#;Some f) (#;Some a)]
+      (#;Some (f a))
+
+      _
+      #;None)))
+
+(struct: #export _ (Monad Maybe)
+  (def: applicative Applicative)
+
+  (def: (join mma)
+    (case mma
+      #;None      #;None
+      (#;Some xs) xs)))
+
+(struct: #export (Eq Eq) (All [a] (-> (Eq a) (Eq (Maybe a))))
+  (def: (= mx my)
+    (case [mx my]
+      [#;None #;None]
+      true
+
+      [(#;Some x) (#;Some y)]
+      (:: Eq = x y)
+      
+      _
+      false)))
+
+(struct: #export (MaybeT Monad)
+  (All [M] (-> (Monad M) (Monad (All [a] (M (Maybe a))))))
+  (def: applicative (A;compA (get@ #M;applicative Monad) Applicative))
+  (def: (join MmMma)
+    (do Monad
+      [mMma MmMma]
+      (case mMma
+        #;None
+        (wrap #;None)
+
+        (#;Some Mma)
+        (join Mma)))))
+
+(def: #export (lift-maybe Monad)
+  (All [M a] (-> (Monad M) (-> (M a) (M (Maybe a)))))
+  (liftM Monad (:: Monad wrap)))
diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux
new file mode 100644
index 000000000..41c75402e
--- /dev/null
+++ b/stdlib/source/lux/data/number.lux
@@ -0,0 +1,222 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control number
+                monoid
+                eq
+                hash
+                [ord]
+                enum
+                bounded
+                codec)
+       (data error)))
+
+## [Structures]
+(do-template [ ]
+  [(struct: #export _ (Eq )
+     (def: = ))]
+
+  [ Nat =+]
+  [ Int =]
+  [Frac =..]
+  [Real =.]
+  )
+
+(do-template [     ]
+  [(struct: #export _ (ord;Ord )
+     (def: eq )
+     (def: < )
+     (def: <= )
+     (def: > )
+     (def: >= ))]
+
+  [ Nat  Eq <+  <=+  >+  >=+]
+  [ Int  Eq <   <=   >   >=]
+  [Frac Eq <.. <=.. >.. >=..]
+  [Real Eq <.  <=.  >.  >=.]
+  )
+
+(struct: #export _ (Number Nat)
+  (def: ord Ord)
+  (def: + ++)
+  (def: - -+)
+  (def: * *+)
+  (def: / /+)
+  (def: % %+)
+  (def: negate id)
+  (def: abs id)
+  (def: (signum x)
+    (case x
+      +0 +0
+      _  +1))
+  )
+
+(do-template [  <+> <-> <*>  <%> <=> <<> <0> <1> <-1>]
+  [(struct: #export _ (Number )
+     (def: ord )
+     (def: + <+>)
+     (def: - <->)
+     (def: * <*>)
+     (def: / )
+     (def: % <%>)
+     (def: negate (<*> <-1>))
+     (def: (abs x)
+       (if (<<> <0> x)
+         (<*> <-1> x)
+         x))
+     (def: (signum x)
+       (cond (<=> <0> x) <0>
+             (<<> <0> x) <-1>
+             ## else
+             <1>))
+     )]
+
+  [ Int  Ord +  -  *  /  %  =  <  0   1   -1]
+  [Real Ord +. -. *. /. %. =. <. 0.0 1.0 -1.0]
+  )
+
+(do-template [   ]
+  [(struct: #export _ (Enum )
+     (def: ord )
+     (def: succ )
+     (def: pred ))]
+
+  [Nat Ord (++ +1) (-+ +1)]
+  [Int Ord inc    dec]
+  )
+
+(do-template [  ]
+  [(struct: #export _ (Bounded )
+     (def: top )
+     (def: bottom ))]
+
+  [ Nat (_lux_proc ["nat" "max-value"] [])                            (_lux_proc ["nat" "min-value"] [])]
+  [ Int (_lux_proc ["jvm" "getstatic:java.lang.Long:MAX_VALUE"] [])   (_lux_proc ["jvm" "getstatic:java.lang.Long:MIN_VALUE"] [])]
+  [Real (_lux_proc ["jvm" "getstatic:java.lang.Double:MAX_VALUE"] []) (_lux_proc ["jvm" "getstatic:java.lang.Double:MIN_VALUE"] [])])
+
+(do-template [   ]
+  [(struct: #export  (Monoid )
+     (def: unit )
+     (def: (append x y) ( x y)))]
+
+  [ Add@Monoid  Nat +0                       ++]
+  [ Mul@Monoid  Nat +1                       *+]
+  [ Max@Monoid  Nat (:: Bounded bottom)  max+]
+  [ Min@Monoid  Nat (:: Bounded top)     min+]
+  [ Add@Monoid  Int 0                        +]
+  [ Mul@Monoid  Int 1                        *]
+  [ Max@Monoid  Int (:: Bounded bottom)  max]
+  [ Min@Monoid  Int (:: Bounded top)     min]
+  [Add@Monoid Real 0.0                      +.]
+  [Mul@Monoid Real 1.0                      *.]
+  [Max@Monoid Real (:: Bounded bottom) max.]
+  [Min@Monoid Real (:: Bounded top)    min.]
+  )
+
+(def: (text.replace pattern value template)
+  (-> Text Text Text Text)
+  (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value]))
+
+(do-template [   ]
+  [(struct: #export _ (Codec Text )
+     (def: (encode x)
+       (_lux_proc  [x]))
+
+     (def: (decode input)
+       (case (_lux_proc  [input])
+         (#;Some value)
+         (#;Right value)
+
+         #;None
+         (#;Left ))))]
+
+  [Nat  ["nat" "encode"]  ["nat" "decode"]  "Couldn't decode Nat"]
+  [Frac ["frac" "encode"] ["frac" "decode"] "Couldn't decode Frac"]
+  )
+
+(def: clean-number
+  (-> Text Text)
+  (|>. (text.replace "," "")
+       (text.replace "_" "")))
+
+(do-template [   ]
+  [(struct: #export _ (Codec Text )
+     (def: (encode x)
+       (_lux_proc ["jvm" ] [x]))
+
+     (def: (decode input)
+       (_lux_proc ["jvm" "try"]
+                  [(#;Right (_lux_proc ["jvm" ] [(clean-number input)]))
+                   (lambda [e] (#;Left ))])))]
+
+  [ Int "invokevirtual:java.lang.Object:toString:" "invokestatic:java.lang.Long:parseLong:java.lang.String"     "Couldn't parse Int"]
+  [Real "invokevirtual:java.lang.Object:toString:" "invokestatic:java.lang.Double:parseDouble:java.lang.String" "Couldn't parse Real"]
+  )
+
+(struct: #export _ (Hash Nat)
+  (def: eq Eq)
+  (def: hash id))
+
+(struct: #export _ (Hash Int)
+  (def: eq Eq)
+  (def: hash int-to-nat))
+
+(struct: #export _ (Hash Real)
+  (def: eq Eq)
+  
+  (def: hash
+    (|>. (:: Codec encode)
+         []
+         (_lux_proc ["jvm" "invokevirtual:java.lang.Object:hashCode:"])
+         []
+         (_lux_proc ["jvm" "i2l"])
+         int-to-nat)))
+
+## [Values & Syntax]
+(do-template [     ]
+  [(struct: #export  (Codec Text Nat)
+     (def: (encode value)
+       (_lux_proc ["jvm" ] [(nat-to-int value)]))
+
+     (def: (decode repr)
+       (_lux_proc ["jvm" "try"]
+                  [(#;Right (int-to-nat (_lux_proc ["jvm" "invokestatic:java.lang.Long:valueOf:java.lang.String,int"] [repr (_lux_proc ["jvm" "l2i"] [])])))
+                   (lambda [ex] (#;Left ))])))
+
+   (macro: #export ( tokens state)
+     {#;doc }
+     (case tokens
+       (#;Cons [meta (#;TextS repr)] #;Nil)
+       (case (::  decode repr)
+         (#;Right value)
+         (#;Right [state (list [meta (#;NatS value)])])
+
+         (#;Left error)
+         (#;Left error))
+
+       _
+       (#;Left )))]
+
+  [Binary@Codec "invokestatic:java.lang.Long:toBinaryString:long" 2  bin "Invalid binary syntax."
+   (doc "Given syntax for a binary number, generates a Nat."
+        (bin "11001001"))]
+  [Octal@Codec  "invokestatic:java.lang.Long:toOctalString:long"  8  oct "Invalid octal syntax."
+   (doc "Given syntax for an octal number, generates a Nat."
+        (oct "0615243"))]
+  [Hex@Codec    "invokestatic:java.lang.Long:toHexString:long"    16 hex "Invalid hexadecimal syntax."
+   (doc "Given syntax for a hexadecimal number, generates a Nat."
+        (hex "deadBEEF"))]
+  )
+
+(do-template [ ]
+  [(def: #export  Real
+     (_lux_proc ["jvm" ] []))]
+
+  [nan  "getstatic:java.lang.Double:NaN"]
+  [+inf "getstatic:java.lang.Double:POSITIVE_INFINITY"]
+  [-inf "getstatic:java.lang.Double:NEGATIVE_INFINITY"]
+  )
diff --git a/stdlib/source/lux/data/product.lux b/stdlib/source/lux/data/product.lux
new file mode 100644
index 000000000..f542d7a38
--- /dev/null
+++ b/stdlib/source/lux/data/product.lux
@@ -0,0 +1,35 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module: lux)
+
+## [Functions]
+(do-template [  ]
+  [(def: #export ( xy)
+     (All [a b] (-> [a b] ))
+     (let [[x y] xy]
+       ))]
+
+  [left  a x]
+  [right b 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))))
+
+(def: #export (swap xy)
+  (All [a b] (-> [a b] [b a]))
+  (let [[x y] xy]
+    [y x]))
diff --git a/stdlib/source/lux/data/struct/array.lux b/stdlib/source/lux/data/struct/array.lux
new file mode 100644
index 000000000..6c81683d3
--- /dev/null
+++ b/stdlib/source/lux/data/struct/array.lux
@@ -0,0 +1,224 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monoid
+                functor
+                applicative
+                monad
+                eq
+                fold)
+       (data error
+             (struct [list "List/" Fold])
+             [product])
+       ))
+
+## [Types]
+(type: #export (Array a)
+  (#;HostT "#Array" (#;Cons a #;Nil)))
+
+## [Functions]
+(def: #export (new size)
+  (All [a] (-> Nat (Array a)))
+  (_lux_proc ["array" "new"] [size]))
+
+(def: #export (size xs)
+  (All [a] (-> (Array a) Nat))
+  (_lux_proc ["array" "size"] [xs]))
+
+(def: #export (get i xs)
+  (All [a]
+    (-> Nat (Array a) (Maybe a)))
+  (_lux_proc ["array" "get"] [xs i]))
+
+(def: #export (put i x xs)
+  (All [a]
+    (-> Nat a (Array a) (Array a)))
+  (_lux_proc ["array" "put"] [xs i x]))
+
+(def: #export (remove i xs)
+  (All [a]
+    (-> Nat (Array a) (Array a)))
+  (_lux_proc ["array" "remove"] [xs i]))
+
+(def: #export (copy length src-start src-array dest-start dest-array)
+  (All [a] (-> Nat Nat (Array a) Nat (Array a)
+               (Array a)))
+  (if (=+ +0 length)
+    dest-array
+    (List/fold (lambda [offset target]
+                 (case (get (++ offset src-start) src-array)
+                   #;None
+                   target
+                   
+                   (#;Some value)
+                   (put (++ offset dest-start) value target)))
+               dest-array
+               (list;range+ +0 (dec+ length)))))
+
+(def: #export (occupied array)
+  {#;doc "Finds out how many cells in an array are occupied."}
+  (All [a] (-> (Array a) Nat))
+  (List/fold (lambda [idx count]
+               (case (get idx array)
+                 #;None
+                 count
+                 
+                 (#;Some _)
+                 (inc+ count)))
+             +0
+             (list;indices (size array))))
+
+(def: #export (vacant array)
+  {#;doc "Finds out how many cells in an array are vacant."}
+  (All [a] (-> (Array a) Nat))
+  (-+ (occupied array) (size array)))
+
+(def: #export (filter p xs)
+  (All [a]
+    (-> (-> a Bool) (Array a) (Array a)))
+  (List/fold (: (-> Nat (Array ($ 0)) (Array ($ 0)))
+                (lambda [idx xs']
+                  (case (get idx xs)
+                    #;None
+                    xs'
+
+                    (#;Some x)
+                    (if (p x)
+                      xs'
+                      (remove idx xs')))))
+             xs
+             (list;indices (size xs))))
+
+(def: #export (find p xs)
+  (All [a]
+    (-> (-> a Bool) (Array a) (Maybe a)))
+  (let [arr-size (size xs)]
+    (loop [idx +0]
+      (if (<+ arr-size idx)
+        (case (get idx xs)
+          #;None
+          (recur (inc+ idx))
+          
+          (#;Some x)
+          (if (p x)
+            (#;Some x)
+            (recur (inc+ idx))))
+        #;None))))
+
+(def: #export (find+ p xs)
+  {#;doc "Just like 'find', but with access to the index of each value."}
+  (All [a]
+    (-> (-> Nat a Bool) (Array a) (Maybe [Nat a])))
+  (let [arr-size (size xs)]
+    (loop [idx +0]
+      (if (<+ arr-size idx)
+        (case (get idx xs)
+          #;None
+          (recur (inc+ idx))
+          
+          (#;Some x)
+          (if (p idx x)
+            (#;Some [idx x])
+            (recur (inc+ idx))))
+        #;None))))
+
+(def: #export (clone xs)
+  (All [a] (-> (Array a) (Array a)))
+  (let [arr-size (size xs)]
+    (List/fold (lambda [idx ys]
+                 (case (get idx xs)
+                   #;None
+                   ys
+
+                   (#;Some x)
+                   (put idx x ys)))
+               (new arr-size)
+               (list;indices arr-size))))
+
+(def: #export (from-list xs)
+  (All [a] (-> (List a) (Array a)))
+  (product;right (List/fold (lambda [x [idx arr]]
+                              [(inc+ idx) (put idx x arr)])
+                            [+0 (new (list;size xs))]
+                            xs)))
+
+(def: #export (to-list array)
+  (All [a] (-> (Array a) (List a)))
+  (let [_size (size array)]
+    (product;right (List/fold (lambda [_ [idx tail]]
+                                (case (get idx array)
+                                  (#;Some head)
+                                  [(dec+ idx) (#;Cons head tail)]
+
+                                  #;None
+                                  [(dec+ idx) tail]))
+                              [(dec+ _size) #;Nil]
+                              (list;repeat _size [])
+                              ))))
+
+## [Structures]
+(struct: #export (Eq (^open "a:"))
+  (All [a] (-> (Eq a) (Eq (Array a))))
+  (def: (= xs ys)
+    (let [sxs (size xs)
+          sxy (size ys)]
+      (and (lux;=+ sxy sxs)
+           (List/fold (lambda [idx prev]
+                        (and prev
+                             (case [(get idx xs) (get idx ys)]
+                               [#;None #;None]
+                               true
+
+                               [(#;Some x) (#;Some y)]
+                               (a:= x y)
+
+                               _
+                               false)))
+                      true
+                      (list;range+ +0 (dec+ sxs)))))
+    ))
+
+(struct: #export Monoid (All [a]
+                                 (Monoid (Array a)))
+  (def: unit (new +0))
+
+  (def: (append xs ys)
+    (let [sxs (size xs)
+          sxy (size ys)]
+      (|> (new (++ sxy sxs))
+          (copy sxs +0 xs +0)
+          (copy sxy +0 ys sxs)))))
+
+(struct: #export _ (Functor Array)
+  (def: (map f ma)
+    (let [arr-size (size ma)]
+      (if (=+ +0 arr-size)
+        (new arr-size)
+        (List/fold (: (-> Nat (Array ($ 1)) (Array ($ 1)))
+                      (lambda [idx mb]
+                        (case (get idx ma)
+                          #;None
+                          mb
+
+                          (#;Some x)
+                          (put idx (f x) mb))))
+                   (new arr-size)
+                   (list;range+ +0 (dec+ arr-size)))))))
+
+(struct: #export _ (Fold Array)
+  (def: (fold f init xs)
+    (let [arr-size (size xs)]
+      (loop [so-far init
+             idx +0]
+        (if (<+ arr-size idx)
+          (case (get idx xs)
+            #;None
+            (recur so-far (inc+ idx))
+
+            (#;Some value)
+            (recur (f value so-far) (inc+ idx)))
+          so-far)))))
diff --git a/stdlib/source/lux/data/struct/dict.lux b/stdlib/source/lux/data/struct/dict.lux
new file mode 100644
index 000000000..a10e30dca
--- /dev/null
+++ b/stdlib/source/lux/data/struct/dict.lux
@@ -0,0 +1,675 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control hash
+                eq)
+       (data maybe
+             (struct [list "List/" Fold Functor Monoid]
+                     [array #+ Array "Array/" Functor Fold])
+             [bit]
+             [product]
+             text/format
+             [number])
+       ))
+
+## This implementation of Hash Array Mapped Trie (HAMT) is based on
+## Clojure's PersistentHashMap implementation.
+## That one is further based on Phil Bagwell's Hash Array Mapped Trie.
+
+## [Utils]
+## Bitmaps are used to figure out which branches on a #Base node are
+## populated. The number of bits that are 1s in a bitmap signal the
+## size of the #Base node.
+(type: BitMap Nat)
+
+## Represents the position of a node in a BitMap.
+## It's meant to be a single bit set on a 32-bit word.
+## The position of the bit reflects whether an entry in an analogous
+## position exists within a #Base, as reflected in it's BitMap.
+(type: BitPosition Nat)
+
+## An index into an array.
+(type: Index Nat)
+
+## A hash-code derived from a key during tree-traversal.
+(type: Hash-Code Nat)
+
+## Represents the nesting level of a leaf or node, when looking-it-up
+## while exploring the tree.
+## Changes in levels are done by right-shifting the hashes of keys by
+## the appropriate multiple of the branching-exponent.
+## A shift of 0 means root level.
+## A shift of (* branching-exponent 1) means level 2.
+## A shift of (* branching-exponent N) means level N+1.
+(type: Level Nat)
+
+## Nodes for the tree data-structure that organizes the data inside
+## Dicts.
+(type: (Node k v)
+  (#Hierarchy Nat (Array (Node k v)))
+  (#Base BitMap
+         (Array (Either (Node k v)
+                        [k v])))
+  (#Collisions Hash-Code (Array [k v])))
+
+## #Hierarchy nodes are meant to point down only to lower-level nodes.
+(type: (Hierarchy k v)
+  [Nat (Array (Node k v))])
+
+## #Base nodes may point down to other nodes, but also to leaves,
+## which are KV pairs.
+(type: (Base k v)
+  (Array (Either (Node k v)
+                 [k v])))
+
+## #Collisions are collections of KV-pairs for which the key is
+## different on each case, but their hashes are all the same (thus
+## causing a collision).
+(type: (Collisions k v)
+  (Array [k v]))
+
+## That bitmap for an empty #Base is 0.
+## Which is the same as 0000 0000 0000 0000 0000 0000 0000 0000.
+## Or 0x00000000.
+## Which is 32 zeroes, since the branching factor is 32.
+(def: clean-bitmap
+  BitMap
+  +0)
+
+## Bitmap position (while looking inside #Base nodes) is determined by
+## getting 5 bits from a hash of the key being looked up and using
+## them as an index into the array inside #Base.
+## Since the data-structure can have multiple levels (and the hash has
+## more than 5 bits), the binary-representation of the hash is shifted
+## by 5 positions on each step (2^5 = 32, which is the branching
+## factor).
+## The initial shifting level, though, is 0 (which corresponds to the
+## shift in the shallowest node on the tree, which is the root node).
+(def: root-level
+  Level
+  +0)
+
+## The exponent to which 2 must be elevated, to reach the branching
+## factor of the data-structure.
+(def: branching-exponent
+  Nat
+  +5)
+
+## The threshold on which #Hierarchy nodes are demoted to #Base nodes,
+## which is 1/4 of the branching factor (or a left-shift 2).
+(def: demotion-threshold
+  Nat
+  (bit;<< (-+ +2 branching-exponent) +1))
+
+## The threshold on which #Base nodes are promoted to #Hierarchy nodes,
+## which is 1/2 of the branching factor (or a left-shift 1).
+(def: promotion-threshold
+  Nat
+  (bit;<< (-+ +1 branching-exponent) +1))
+
+## The size of hierarchy-nodes, which is 2^(branching-exponent).
+(def: hierarchy-nodes-size
+  Nat
+  (bit;<< branching-exponent +1))
+
+## The cannonical empty node, which is just an empty #Base node.
+(def: empty
+  Node
+  (#Base clean-bitmap (array;new +0)))
+
+## Expands a copy of the array, to have 1 extra slot, which is used
+## for storing the value.
+(def: (insert! idx value old-array)
+  (All [a] (-> Index a (Array a) (Array a)))
+  (let [old-size (array;size old-array)]
+    (|> (: (Array ($ 0))
+           (array;new (inc+ old-size)))
+        (array;copy idx +0 old-array +0)
+        (array;put idx value)
+        (array;copy (-+ idx old-size) idx old-array (inc+ idx)))))
+
+## Creates a copy of an array with an index set to a particular value.
+(def: (update! idx value array)
+  (All [a] (-> Index a (Array a) (Array a)))
+  (|> array array;clone (array;put idx value)))
+
+## Creates a clone of the array, with an empty position at index.
+(def: (vacant! idx array)
+  (All [a] (-> Index (Array a) (Array a)))
+  (|> array array;clone (array;remove idx)))
+
+## Shrinks a copy of the array by removing the space at index.
+(def: (remove! idx array)
+  (All [a] (-> Index (Array a) (Array a)))
+  (let [new-size (dec+ (array;size array))]
+    (|> (array;new new-size)
+        (array;copy idx +0 array +0)
+        (array;copy (-+ idx new-size) (inc+ idx) array idx))))
+
+## Given a top-limit for indices, produces all indices in [0, R).
+(def: indices-for
+  (-> Nat (List Index))
+  (|>. dec+ (list;range+ +0)))
+
+## Increases the level-shift by the branching-exponent, to explore
+## levels further down the tree.
+(def: level-up
+  (-> Level Level)
+  (++ branching-exponent))
+
+(def: hierarchy-mask BitMap (dec+ hierarchy-nodes-size))
+
+## Gets the branching-factor sized section of the hash corresponding
+## to a particular level, and uses that as an index into the array.
+(def: (level-index level hash)
+  (-> Level Hash-Code Index)
+  (bit;& hierarchy-mask
+         (bit;>>> level hash)))
+
+## A mechanism to go from indices to bit-positions.
+(def: (->bit-position index)
+  (-> Index BitPosition)
+  (bit;<< index +1))
+
+## The bit-position within a base that a given hash-code would have.
+(def: (bit-position level hash)
+  (-> Level Hash-Code BitPosition)
+  (->bit-position (level-index level hash)))
+
+(def: (bit-position-is-set? bit bitmap)
+  (-> BitPosition BitMap Bool)
+  (not (=+ clean-bitmap (bit;& bit bitmap))))
+
+## Figures out whether a bitmap only contains a single bit-position.
+(def: only-bit-position?
+  (-> BitPosition BitMap Bool)
+  =+)
+
+(def: (set-bit-position bit bitmap)
+  (-> BitPosition BitMap BitMap)
+  (bit;| bit bitmap))
+
+(def: unset-bit-position
+  (-> BitPosition BitMap BitMap)
+  bit;^)
+
+## Figures out the size of a bitmap-indexed array by counting all the
+## 1s within the bitmap.
+(def: bitmap-size
+  (-> BitMap Nat)
+  bit;count)
+
+## A mask that, for a given bit position, only allows all the 1s prior
+## to it, which would indicate the bitmap-size (and, thus, index)
+## associated with it.
+(def: bit-position-mask
+  (-> BitPosition BitMap)
+  dec+)
+
+## The index on the base array, based on it's bit-position.
+(def: (base-index bit-position bitmap)
+  (-> BitPosition BitMap Index)
+  (bitmap-size (bit;& (bit-position-mask bit-position)
+                      bitmap)))
+
+## Produces the index of a KV-pair within a #Collisions node.
+(def: (collision-index Hash key colls)
+  (All [K V] (-> (Hash K) K (Collisions K V) (Maybe Index)))
+  (:: Monad map product;left
+      (array;find+ (lambda [idx [key' val']]
+                     (:: Hash = key key'))
+                   colls)))
+
+## When #Hierarchy nodes grow too small, they're demoted to #Base
+## nodes to save space.
+(def: (demote-hierarchy except-idx [h-size h-array])
+  (All [k v] (-> Index (Hierarchy k v) [BitMap (Base k v)]))
+  (List/fold (lambda [idx (^@ node [bitmap base])]
+               (case (array;get idx h-array)
+                 #;None            node
+                 (#;Some sub-node) (if (=+ except-idx idx)
+                                     node
+                                     [(set-bit-position (->bit-position idx) bitmap)
+                                      (array;put idx (#;Left sub-node) base)])
+                 ))
+             [clean-bitmap
+              (: (Base ($ 0) ($ 1))
+                 (array;new (dec+ h-size)))]
+             (list;indices (array;size h-array))))
+
+## When #Base nodes grow too large, they're promoted to #Hierarchy to
+## add some depth to the tree and help keep it's balance.
+(def: (promote-base put' Hash level bitmap base)
+  (All [K V]
+    (-> (-> Level Hash-Code K V (Hash K) (Node K V) (Node K V))
+        (Hash K) Level
+        BitMap (Base K V)
+        (Array (Node K V))))
+  (product;right (List/fold (lambda [hierarchy-idx (^@ default [base-idx h-array])]
+                              (if (bit-position-is-set? (->bit-position hierarchy-idx)
+                                                        bitmap)
+                                [(inc+ base-idx)
+                                 (case (array;get base-idx base)
+                                   (#;Some (#;Left sub-node))
+                                   (array;put hierarchy-idx sub-node h-array)
+
+                                   (#;Some (#;Right [key' val']))
+                                   (array;put hierarchy-idx
+                                              (put' (level-up level) (:: Hash hash key') key' val' Hash empty)
+                                              h-array)
+
+                                   #;None
+                                   (undefined))]
+                                default))
+                            [+0
+                             (: (Array (Node ($ 0) ($ 1)))
+                                (array;new hierarchy-nodes-size))]
+                            (indices-for hierarchy-nodes-size))))
+
+## All empty nodes look the same (a #Base node with clean bitmap is
+## used).
+## So, this test is introduced to detect them.
+(def: (empty?' node)
+  (All [K V] (-> (Node K V) Bool))
+  (case node
+    (^~ (#Base ;;clean-bitmap _))
+    true
+
+    _
+    false))
+
+(def: (put' level hash key val Hash node)
+  (All [K V] (-> Level Hash-Code K V (Hash K) (Node K V) (Node K V)))
+  (case node
+    ## For #Hierarchy nodes, I check whether I can add the element to
+    ## a sub-node. If impossible, I introduced a new singleton sub-node.
+    (#Hierarchy _size hierarchy)
+    (let [idx (level-index level hash)
+          [_size' sub-node] (: [Nat (Node ($ 0) ($ 1))]
+                               (case (array;get idx hierarchy)
+                                 (#;Some sub-node)
+                                 [_size sub-node]
+
+                                 _
+                                 [(inc+ _size) empty]))]
+      (#Hierarchy _size'
+                  (update! idx (put' (level-up level) hash key val Hash sub-node)
+                           hierarchy)))
+
+    ## For #Base nodes, I check if the corresponding BitPosition has
+    ## already been used.
+    (#Base bitmap base)
+    (let [bit (bit-position level hash)]
+      (if (bit-position-is-set? bit bitmap)
+        ## If so...
+        (let [idx (base-index bit bitmap)]
+          (case (array;get idx base)
+            #;None
+            (undefined)
+
+            ## If it's being used by a node, I add the KV to it.
+            (#;Some (#;Left sub-node))
+            (let [sub-node' (put' (level-up level) hash key val Hash sub-node)]
+              (#Base bitmap (update! idx (#;Left sub-node') base)))
+
+            ## Otherwise, if it's being used by a KV, I compare the keys.
+            (#;Some (#;Right key' val'))
+            (if (:: Hash = key key')
+              ## If the same key is found, I replace the value.
+              (#Base bitmap (update! idx (#;Right key val) base))
+              ## Otherwise, I compare the hashes of the keys.
+              (#Base bitmap (update! idx
+                                     (#;Left (let [hash' (:: Hash hash key')]
+                                               (if (=+ hash hash')
+                                                 ## If the hashes are
+                                                 ## the same, a new
+                                                 ## #Collisions node
+                                                 ## is added.
+                                                 (#Collisions hash (|> (: (Array [($ 0) ($ 1)])
+                                                                          (array;new +2))
+                                                                       (array;put +0 [key' val'])
+                                                                       (array;put +1 [key val])))
+                                                 ## Otherwise, I can
+                                                 ## just keep using
+                                                 ## #Base nodes, so I
+                                                 ## add both KV pairs
+                                                 ## to the empty one.
+                                                 (let [next-level (level-up level)]
+                                                   (|> empty
+                                                       (put' next-level hash' key' val' Hash)
+                                                       (put' next-level hash  key  val Hash))))))
+                                     base)))))
+        ## However, if the BitPosition has not been used yet, I check
+        ## whether this #Base node is ready for a promotion.
+        (let [base-count (bitmap-size bitmap)]
+          (if (>=+ promotion-threshold base-count)
+            ## If so, I promote it to a #Hierarchy node, and add the new
+            ## KV-pair as a singleton node to it.
+            (#Hierarchy (inc+ base-count)
+                        (|> (promote-base put' Hash level bitmap base)
+                            (array;put (level-index level hash)
+                                       (put' (level-up level) hash key val Hash empty))))
+            ## Otherwise, I just resize the #Base node to accommodate the
+            ## new KV-pair.
+            (#Base (set-bit-position bit bitmap)
+                   (insert! (base-index bit bitmap) (#;Right [key val]) base))))))
+    
+    ## For #Collisions nodes, I compare the hashes.
+    (#Collisions _hash _colls)
+    (if (=+ hash _hash)
+      ## If they're equal, that means the new KV contributes to the
+      ## collisions.
+      (case (collision-index Hash key _colls)
+        ## If the key was already present in the collisions-list, it's
+        ## value gets updated.
+        (#;Some coll-idx)
+        (#Collisions _hash (update! coll-idx [key val] _colls))
+
+        ## Otherwise, the KV-pair is added to the collisions-list.
+        #;None
+        (#Collisions _hash (insert! (array;size _colls) [key val] _colls)))
+      ## If the hashes are not equal, I create a new #Base node that
+      ## contains the old #Collisions node, plus the new KV-pair.
+      (|> (#Base (bit-position level _hash)
+                 (|> (: (Base ($ 0) ($ 1))
+                        (array;new +1))
+                     (array;put +0 (#;Left node))))
+          (put' level hash key val Hash)))
+    ))
+
+(def: (remove' level hash key Hash node)
+  (All [K V] (-> Level Hash-Code K (Hash K) (Node K V) (Node K V)))
+  (case node
+    ## For #Hierarchy nodes, find out if there's a valid sub-node for
+    ## the Hash-Code.
+    (#Hierarchy h-size h-array)
+    (let [idx (level-index level hash)]
+      (case (array;get idx h-array)
+        ## If not, there's nothing to remove.
+        #;None
+        node
+
+        ## But if there is, try to remove the key from the sub-node.
+        (#;Some sub-node)
+        (let [sub-node' (remove' (level-up level) hash key Hash sub-node)]
+          ## Then check if a removal was actually done.
+          (if (== sub-node sub-node')
+            ## If not, then there's nothing to change here either.
+            node
+            ## But if the sub-removal yielded an empty sub-node...
+            (if (empty?' sub-node')
+              ## Check if it's due time for a demotion.
+              (if (<=+ demotion-threshold h-size)
+                ## If so, perform it.
+                (#Base (demote-hierarchy idx [h-size h-array]))
+                ## Otherwise, just clear the space.
+                (#Hierarchy (dec+ h-size) (vacant! idx h-array)))
+              ## But if the sub-removal yielded a non-empty node, then
+              ## just update the hiearchy branch.
+              (#Hierarchy h-size (update! idx sub-node' h-array)))))))
+
+    ## For #Base nodes, check whether the BitPosition is set.
+    (#Base bitmap base)
+    (let [bit (bit-position level hash)]
+      (if (bit-position-is-set? bit bitmap)
+        (let [idx (base-index bit bitmap)]
+          (case (array;get idx base)
+            #;None
+            (undefined)
+
+            ## If set, check if it's a sub-node, and remove the KV
+            ## from it.
+            (#;Some (#;Left sub-node))
+            (let [sub-node' (remove' (level-up level) hash key Hash sub-node)]
+              ## Verify that it was removed.
+              (if (== sub-node sub-node')
+                ## If not, there's also nothing to change here.
+                node
+                ## But if it came out empty...
+                (if (empty?' sub-node')
+                  ### ... figure out whether that's the only position left.
+                  (if (only-bit-position? bit bitmap)
+                    ## If so, removing it leaves this node empty too.
+                    empty
+                    ## But if not, then just unset the position and
+                    ## remove the node.
+                    (#Base (unset-bit-position bit bitmap)
+                           (remove! idx base)))
+                  ## But, if it didn't come out empty, then the
+                  ## position is kept, and the node gets updated.
+                  (#Base bitmap
+                         (update! idx (#;Left sub-node') base)))))
+
+            ## If, however, there was a KV pair instead of a sub-node.
+            (#;Some (#;Right [key' val']))
+            ## Check if the keys match.
+            (if (:: Hash = key key')
+              ## If so, remove the KV pair and unset the BitPosition.
+              (#Base (unset-bit-position bit bitmap)
+                     (remove! idx base))
+              ## Otherwise, there's nothing to remove.
+              node)))
+        ## If the BitPosition is not set, there's nothing to remove.
+        node))
+
+    ## For #Collisions nodes, It need to find out if the key already existst.
+    (#Collisions _hash _colls)
+    (case (collision-index Hash key _colls)
+      ## If not, then there's nothing to remove.
+      #;None
+      node
+
+      ## But if so, then check the size of the collisions list.
+      (#;Some idx)
+      (if (=+ +1 (array;size _colls))
+        ## If there's only one left, then removing it leaves us with
+        ## an empty node.
+        empty
+        ## Otherwise, just shrink the array by removing the KV pair.
+        (#Collisions _hash (remove! idx _colls))))
+    ))
+
+(def: (get' level hash key Hash node)
+  (All [K V] (-> Level Hash-Code K (Hash K) (Node K V) (Maybe V)))
+  (case node
+    ## For #Hierarchy nodes, just look-up the key on its children.
+    (#Hierarchy _size hierarchy)
+    (case (array;get (level-index level hash) hierarchy)
+      #;None            #;None
+      (#;Some sub-node) (get' (level-up level) hash key Hash sub-node))
+
+    ## For #Base nodes, check the leaves, and recursively check the branches.
+    (#Base bitmap base)
+    (let [bit (bit-position level hash)]
+      (if (bit-position-is-set? bit bitmap)
+        (case (array;get (base-index bit bitmap) base)
+          #;None
+          (undefined)
+          
+          (#;Some (#;Left sub-node))
+          (get' (level-up level) hash key Hash sub-node)
+
+          (#;Some (#;Right [key' val']))
+          (if (:: Hash = key key')
+            (#;Some val')
+            #;None))
+        #;None))
+
+    ## For #Collisions nodes, do a linear scan of all the known KV-pairs.
+    (#Collisions _hash _colls)
+    (:: Monad map product;right
+        (array;find (|>. product;left (:: Hash = key))
+                    _colls))
+    ))
+
+(def: (size' node)
+  (All [K V] (-> (Node K V) Nat))
+  (case node
+    (#Hierarchy _size hierarchy)
+    (Array/fold ++ +0 (Array/map size' hierarchy))
+    
+    (#Base _ base)
+    (Array/fold ++ +0 (Array/map (lambda [sub-node']
+                                   (case sub-node'
+                                     (#;Left sub-node) (size' sub-node)
+                                     (#;Right _)       +1))
+                                 base))
+
+    (#Collisions hash colls)
+    (array;size colls)
+    ))
+
+(def: (entries' node)
+  (All [K V] (-> (Node K V) (List [K V])))
+  (case node
+    (#Hierarchy _size hierarchy)
+    (Array/fold (lambda [sub-node tail] (List/append (entries' sub-node) tail))
+                #;Nil
+                hierarchy)
+
+    (#Base bitmap base)
+    (Array/fold (lambda [branch tail]
+                  (case branch
+                    (#;Left sub-node)
+                    (List/append (entries' sub-node) tail)
+
+                    (#;Right [key' val'])
+                    (#;Cons [key' val'] tail)))
+                #;Nil
+                base)
+    
+    (#Collisions hash colls)
+    (Array/fold (lambda [[key' val'] tail] (#;Cons [key' val'] tail))
+                #;Nil
+                colls)))
+
+## [Exports]
+(type: #export (Dict k v)
+  {#;doc "A dictionary implemented as a Hash-Array Mapped Trie (HAMT)."}
+  {#hash (Hash k)
+   #root (Node k v)})
+
+(def: #export (new Hash)
+  (All [K V] (-> (Hash K) (Dict K V)))
+  {#hash Hash
+   #root empty})
+
+(def: #export (put key val [Hash node])
+  (All [K V] (-> K V (Dict K V) (Dict K V)))
+  [Hash (put' root-level (:: Hash hash key) key val Hash node)])
+
+(def: #export (remove key [Hash node])
+  (All [K V] (-> K (Dict K V) (Dict K V)))
+  [Hash (remove' root-level (:: Hash hash key) key Hash node)])
+
+(def: #export (get key [Hash node])
+  (All [K V] (-> K (Dict K V) (Maybe V)))
+  (get' root-level (:: Hash hash key) key Hash node))
+
+(def: #export (contains? key table)
+  (All [K V] (-> K (Dict K V) Bool))
+  (case (get key table)
+    #;None     false
+    (#;Some _) true))
+
+(def: #export (put~ key val table)
+  {#;doc "Only puts the KV-pair if the key is not already present."}
+  (All [K V] (-> K V (Dict K V) (Dict K V)))
+  (if (contains? key table)
+    table
+    (put key val table)))
+
+(def: #export (update key f table)
+  {#;doc "Transforms the value located at key (if available), using the given function."}
+  (All [K V] (-> K (-> V V) (Dict K V) (Dict K V)))
+  (case (get key table)
+    #;None
+    table
+
+    (#;Some val)
+    (put key (f val) table)))
+
+(def: #export size
+  (All [K V] (-> (Dict K V) Nat))
+  (|>. product;right size'))
+
+(def: #export empty?
+  (All [K V] (-> (Dict K V) Bool))
+  (|>. size (=+ +0)))
+
+(def: #export (entries dict)
+  (All [K V] (-> (Dict K V) (List [K V])))
+  (entries' (product;right dict)))
+
+(def: #export (from-list Hash kvs)
+  (All [K V] (-> (Hash K) (List [K V]) (Dict K V)))
+  (List/fold (lambda [[k v] dict]
+               (put k v dict))
+             (new Hash)
+             kvs))
+
+(do-template [  ]
+  [(def: #export 
+     (All [K V] (-> (Dict K V) (List )))
+     (|>. entries (List/map )))]
+
+  [keys   K product;left]
+  [values V product;right]
+  )
+
+(def: #export (merge dict2 dict1)
+  (All [K V] (-> (Dict K V) (Dict K V) (Dict K V)))
+  (List/fold (lambda [[key val] dict] (put key val dict))
+             dict1
+             (entries dict2)))
+
+(def: #export (merge-with f dict1 dict2)
+  (All [K V] (-> (-> V V V) (Dict K V) (Dict K V) (Dict K V)))
+  (List/fold (lambda [[key val] dict]
+               (case (get key dict)
+                 #;None
+                 (put key val dict)
+
+                 (#;Some val')
+                 (put key (f val' val) dict)))
+             dict1
+             (entries dict2)))
+
+(def: #export (re-bind from-key to-key dict)
+  (All [K V] (-> K K (Dict K V) (Dict K V)))
+  (case (get from-key dict)
+    #;None
+    dict
+
+    (#;Some val)
+    (|> dict
+        (remove from-key)
+        (put to-key val))))
+
+(def: #export (select keys (^@ old-dict [Hash _]))
+  {#;doc "Creates a sub-set of the given dict, with only the specified keys."}
+  (All [K V] (-> (List K) (Dict K V) (Dict K V)))
+  (List/fold (lambda [key new-dict]
+               (case (get key old-dict)
+                 #;None       new-dict
+                 (#;Some val) (put key val new-dict)))
+             (new Hash)
+             keys))
+
+## [Structures]
+(struct: #export (Eq Eq) (All [k v] (-> (Eq v) (Eq (Dict k v))))
+  (def: (= test subject)
+    (and (=+ (size test)
+             (size subject))
+         (list;every? (lambda [k]
+                        (case [(get k test) (get k subject)]
+                          [(#;Some tk) (#;Some sk)]
+                          (:: Eq = tk sk)
+
+                          _
+                          false))
+                      (keys test)))))
diff --git a/stdlib/source/lux/data/struct/list.lux b/stdlib/source/lux/data/struct/list.lux
new file mode 100644
index 000000000..7d71e4faa
--- /dev/null
+++ b/stdlib/source/lux/data/struct/list.lux
@@ -0,0 +1,487 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monoid
+                functor
+                applicative
+                ["M" monad #*]
+                eq
+                [fold])
+       (data [number "Int/" Number Codec]
+             bool
+             [product])
+       codata/function))
+
+## [Types]
+## (type: (List a)
+##   #Nil
+##   (#Cons a (List a)))
+
+## [Functions]
+(struct: #export _ (fold;Fold List)
+  (def: (fold f init xs)
+    (case xs
+      #;Nil
+      init
+
+      (#;Cons [x xs'])
+      (fold f (f x init) xs'))))
+
+(open Fold)
+
+(def: #export (reverse xs)
+  (All [a]
+    (-> (List a) (List a)))
+  (fold (lambda [head tail] (#;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 [  ]
+  [(def: #export ( n xs)
+     (All [a]
+       (-> Nat (List a) (List a)))
+     (if (>+ +0 n)
+       (case xs
+         #;Nil
+         #;Nil
+         
+         (#;Cons [x xs'])
+         )
+       ))]
+  
+  [take (#;Cons [x (take (-+ +1 n) xs')]) #;Nil]
+  [drop (drop (-+ +1 n) xs') xs]
+  )
+
+(do-template [  ]
+  [(def: #export ( p xs)
+     (All [a]
+       (-> (-> a Bool) (List a) (List a)))
+     (case xs
+       #;Nil
+       #;Nil
+       
+       (#;Cons [x xs'])
+       (if (p x)
+         
+         )))]
+
+  [take-while (#;Cons [x (take-while p xs')]) #;Nil]
+  [drop-while (drop-while p xs') xs]
+  )
+
+(def: #export (split n xs)
+  (All [a]
+    (-> Nat (List a) [(List a) (List a)]))
+  (if (>+ +0 n)
+    (case xs
+      #;Nil
+      [#;Nil #;Nil]
+      
+      (#;Cons [x xs'])
+      (let [[tail rest] (split (-+ +1 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 (split-all n xs)
+  (All [a] (-> Nat (List a) (List (List a))))
+  (case xs
+    #;Nil
+    (list)
+
+    _
+    (let [[pre post] (split n xs)]
+      (#;Cons pre (split-all n post)))))
+
+(def: #export (repeat n x)
+  (All [a]
+    (-> Nat a (List a)))
+  (if (>+ +0 n)
+    (#;Cons [x (repeat (dec+ n) x)])
+    #;Nil))
+
+(def: (iterate' f x)
+  (All [a]
+    (-> (-> a (Maybe a)) a (List a)))
+  (case (f x)
+    (#;Some x')
+    (list& x (iterate' f x'))
+
+    #;None
+    (list)))
+
+(def: #export (iterate f x)
+  (All [a]
+    (-> (-> a (Maybe a)) a (List a)))
+  (case (f x)
+    (#;Some x')
+    (list& x (iterate' f x'))
+
+    #;None
+    (list x)))
+
+(def: #export (find p xs)
+  (All [a]
+    (-> (-> a Bool) (List a) (Maybe a)))
+  (case xs
+    #;Nil
+    #;None
+
+    (#;Cons [x xs'])
+    (if (p x)
+      (#;Some x)
+      (find p xs'))))
+
+(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)
+  (All [a] (-> (List a) Nat))
+  (fold (lambda [_ acc] (++ +1 acc)) +0 list))
+
+(do-template [  ]
+  [(def: #export ( p xs)
+     (All [a]
+       (-> (-> a Bool) (List a) Bool))
+     (fold (lambda [_2 _1] ( _1 (p _2)))  xs))]
+
+  [every? true  and]
+  [any?   false or])
+
+(def: #export (at i xs)
+  (All [a]
+    (-> Nat (List a) (Maybe a)))
+  (case xs
+    #;Nil
+    #;None
+
+    (#;Cons [x xs'])
+    (if (=+ +0 i)
+      (#;Some x)
+      (at (-+ +1 i) xs'))))
+
+## [Structures]
+(struct: #export (Eq (^open "a:"))
+  (All [a] (-> (Eq a) (Eq (List a))))
+  (def: (= xs ys)
+    (case [xs ys]
+      [#;Nil #;Nil]
+      true
+
+      [(#;Cons x xs') (#;Cons y ys')]
+      (and (a:= x y)
+           (= xs' ys'))
+
+      [_ _]
+      false
+      )))
+
+(struct: #export Monoid (All [a]
+                                (Monoid (List a)))
+  (def: unit #;Nil)
+  (def: (append xs ys)
+    (case xs
+      #;Nil          ys
+      (#;Cons x xs') (#;Cons x (append xs' ys)))))
+
+(open Monoid)
+
+(struct: #export _ (Functor List)
+  (def: (map f ma)
+    (case ma
+      #;Nil          #;Nil
+      (#;Cons a ma') (#;Cons (f a) (map f ma')))))
+
+(open Functor)
+
+(struct: #export _ (Applicative List)
+  (def: functor Functor)
+
+  (def: (wrap a)
+    (#;Cons a #;Nil))
+
+  (def: (apply ff fa)
+    (case ff
+      #;Nil
+      #;Nil
+      
+      (#;Cons f ff')
+      (append (map f fa) (apply ff' fa)))))
+
+(struct: #export _ (Monad List)
+  (def: applicative Applicative)
+
+  (def: join (|>. reverse (fold append unit))))
+
+## [Functions]
+(def: #export (sort < xs)
+  (All [a] (-> (-> a a Bool) (List a) (List a)))
+  (case xs
+    #;Nil
+    (list)
+    
+    (#;Cons x xs')
+    (let [[pre post] (fold (lambda [x' [pre post]]
+                             (if (< x x')
+                               [(#;Cons x' pre) post]
+                               [pre (#;Cons x' post)]))
+                           [(list) (list)]
+                           xs')]
+      ($_ append (sort < pre) (list x) (sort < post)))))
+
+(do-template [   ]
+  [(def: #export ( from to)
+     (->   (List ))
+     (if ( to from)
+       (list& from ( ( from) to))
+       (list)))]
+
+  [range  Int <=  inc]
+  [range+ Nat <=+ inc+]
+  )
+
+(def: #export (empty? xs)
+  (All [a] (-> (List a) Bool))
+  (case xs
+    #;Nil true
+    _     false))
+
+(def: #export (member? eq xs x)
+  (All [a] (-> (Eq a) (List a) a Bool))
+  (case xs
+    #;Nil           false
+    (#;Cons x' xs') (or (:: eq = x x')
+                        (member? eq xs' x))))
+
+(do-template [  ]
+  [(def: #export ( xs)
+     (All [a] (-> (List a) (Maybe )))
+     (case xs
+       #;Nil
+       #;None
+
+       (#;Cons x xs')
+       (#;Some )))]
+
+  [head a        x]
+  [tail (List a) xs']
+  )
+
+## [Syntax]
+(def: (symbol$ name)
+  (-> Text AST)
+  [["" -1 -1] (#;SymbolS "" name)])
+
+(macro: #export (zip tokens state)
+  {#;doc (doc "Create list zippers with the specified number of input lists."
+              (def: #export zip2 (zip 2))
+              (def: #export zip3 (zip 3))
+              ((zip 3) xs ys zs))}
+  (case tokens
+    (^ (list [_ (#;IntS num-lists)]))
+    (if (> 0 num-lists)
+      (let [(^open) Functor
+            indices (range 0 (dec num-lists))
+            type-vars (: (List AST) (map (. symbol$ Int/encode) indices))
+            zip-type (` (All [(~@ type-vars)]
+                          (-> (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var)))))
+                                       type-vars))
+                              (List [(~@ type-vars)]))))
+            vars+lists (|> indices
+                           (map inc)
+                           (map (lambda [idx]
+                                  [(symbol$ (Int/encode idx))
+                                   (symbol$ (Int/encode (Int/negate idx)))])))
+            pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs))))
+                                 vars+lists))])
+            g!step (symbol$ "\tstep\t")
+            g!blank (symbol$ "\t_\t")
+            list-vars (map product;right vars+lists)
+            code (` (: (~ zip-type)
+                       (lambda (~ g!step) [(~@ list-vars)]
+                         (case [(~@ list-vars)]
+                           (~ pattern)
+                           (#;Cons [(~@ (map product;left vars+lists))]
+                                   ((~ g!step) (~@ list-vars)))
+
+                           (~ g!blank)
+                           #;Nil))))]
+        (#;Right [state (list code)]))
+      (#;Left "Can't zip 0 lists."))
+
+    _
+    (#;Left "Wrong syntax for zip")))
+
+(def: #export zip2 (zip 2))
+(def: #export zip3 (zip 3))
+
+(macro: #export (zip-with tokens state)
+  {#;doc (doc "Create list zip-with`s with the specified number of input lists."
+              (def: #export zip2-with (zip-with 2))
+              (def: #export zip3-with (zip-with 3))
+              ((zip-with 2) + xs ys))}
+  (case tokens
+    (^ (list [_ (#;IntS num-lists)]))
+    (if (> 0 num-lists)
+      (let [(^open) Functor
+            indices (range 0 (dec num-lists))
+            g!return-type (symbol$ "\treturn-type\t")
+            g!func (symbol$ "\tfunc\t")
+            type-vars (: (List AST) (map (. symbol$ Int/encode) indices))
+            zip-type (` (All [(~@ type-vars) (~ g!return-type)]
+                          (-> (-> (~@ type-vars) (~ g!return-type))
+                              (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var)))))
+                                       type-vars))
+                              (List (~ g!return-type)))))
+            vars+lists (|> indices
+                           (map inc)
+                           (map (lambda [idx]
+                                  [(symbol$ (Int/encode idx))
+                                   (symbol$ (Int/encode (Int/negate idx)))])))
+            pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs))))
+                                 vars+lists))])
+            g!step (symbol$ "\tstep\t")
+            g!blank (symbol$ "\t_\t")
+            list-vars (map product;right vars+lists)
+            code (` (: (~ zip-type)
+                       (lambda (~ g!step) [(~ g!func) (~@ list-vars)]
+                         (case [(~@ list-vars)]
+                           (~ pattern)
+                           (#;Cons ((~ g!func) (~@ (map product;left vars+lists)))
+                                   ((~ g!step) (~ g!func) (~@ list-vars)))
+
+                           (~ g!blank)
+                           #;Nil))))]
+        (#;Right [state (list code)]))
+      (#;Left "Can't zip-with 0 lists."))
+
+    _
+    (#;Left "Wrong syntax for zip-with")))
+
+(def: #export zip2-with (zip-with 2))
+(def: #export zip3-with (zip-with 3))
+
+(def: #export (last xs)
+  (All [a] (-> (List a) (Maybe a)))
+  (case xs
+    #;Nil
+    #;None
+
+    (#;Cons x #;Nil)
+    (#;Some x)
+    
+    (#;Cons x xs')
+    (last xs')))
+
+(def: #export (inits xs)
+  (All [a] (-> (List a) (Maybe (List a))))
+  (case xs
+    #;Nil
+    #;None
+
+    (#;Cons x #;Nil)
+    (#;Some #;Nil)
+    
+    (#;Cons x xs')
+    (case (inits xs')
+      #;None
+      (undefined)
+
+      (#;Some tail)
+      (#;Some (#;Cons x tail)))
+    ))
+
+(def: #export (concat xss)
+  (All [a] (-> (List (List a)) (List a)))
+  (:: Monad join xss))
+
+(struct: #export (ListT Monad)
+  (All [M] (-> (Monad M) (Monad (All [a] (M (List a))))))
+  (def: applicative (compA (get@ #M;applicative Monad) Applicative))
+  (def: (join MlMla)
+    (do Monad
+      [lMla MlMla
+       lla (: (($ 0) (List (List ($ 1))))
+              (mapM @ join lMla))]
+      (wrap (concat lla)))))
+
+(def: #export (lift-list Monad)
+  (All [M a] (-> (Monad M) (-> (M a) (M (List a)))))
+  (liftM Monad (:: Monad wrap)))
+
+(def: (enumerate' idx xs)
+  (All [a] (-> Nat (List a) (List [Nat a])))
+  (case xs
+    #;Nil
+    #;Nil
+
+    (#;Cons x xs')
+    (#;Cons [idx x] (enumerate' (inc+ idx) xs'))))
+
+(def: #export (enumerate xs)
+  (All [a] (-> (List a) (List [Nat a])))
+  (enumerate' +0 xs))
+
+(def: #export (indices size)
+  {#;doc "Produces all the valid indices for a given size."}
+  (All [a] (-> Nat (List Nat)))
+  (if (=+ +0 size)
+    (list)
+    (|> size dec+ (range+ +0))))
diff --git a/stdlib/source/lux/data/struct/queue.lux b/stdlib/source/lux/data/struct/queue.lux
new file mode 100644
index 000000000..61b97c9cd
--- /dev/null
+++ b/stdlib/source/lux/data/struct/queue.lux
@@ -0,0 +1,79 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control eq)
+       (data (struct [list "List/" Monoid]))))
+
+## [Types]
+(type: #export (Queue a)
+  {#front (List a)
+   #rear (List a)})
+
+## [Values]
+(def: #export empty
+  Queue
+  {#front (list)
+   #rear (list)})
+
+(def: #export (from-list entries)
+  (All [a] (-> (List a) (Queue a)))
+  {#front entries
+   #rear (list)})
+
+(def: #export (to-list queue)
+  (All [a] (-> (Queue a) (List a)))
+  (let [(^slots [#front #rear]) queue]
+    (List/append front (list;reverse rear))))
+
+(def: #export peek
+  (All [a] (-> (Queue a) (Maybe a)))
+  (|>. (get@ #front) list;head))
+
+(def: #export (size queue)
+  (All [a] (-> (Queue a) Nat))
+  (let [(^slots [#front #rear]) queue]
+    (++ (list;size front)
+        (list;size rear))))
+
+(def: #export empty?
+  (All [a] (-> (Queue a) Bool))
+  (|>. (get@ [#front]) list;empty?))
+
+(def: #export (enqueued? a/Eq queue member)
+  (All [a] (-> (Eq a) (Queue a) a Bool))
+  (let [(^slots [#front #rear]) queue]
+    (or (list;member? a/Eq front member)
+        (list;member? a/Eq rear member))))
+
+(def: #export (dequeue queue)
+  (All [a] (-> (Queue a) (Queue a)))
+  (case (get@ #front queue)
+    (^ (list)) ## Empty...
+    queue
+
+    (^ (list _)) ## Front has dried up...
+    (|> queue
+        (set@ #front (list;reverse (get@ #rear queue)))
+        (set@ #rear (list)))
+    
+    (^ (list& _ front')) ## Consume front!
+    (|> queue
+        (set@ #front front'))))
+
+(def: #export (enqueue val queue)
+  (All [a] (-> a (Queue a) (Queue a)))
+  (case (get@ #front queue)
+    #;Nil
+    (set@ #front (list val) queue)
+
+    _
+    (update@ #rear (|>. (#;Cons val)) queue)))
+
+## [Structures]
+(struct: #export (Eq Eq) (All [a] (-> (Eq a) (Eq (Queue a))))
+  (def: (= qx qy)
+    (:: (list;Eq Eq) = (to-list qx) (to-list qy))))
diff --git a/stdlib/source/lux/data/struct/set.lux b/stdlib/source/lux/data/struct/set.lux
new file mode 100644
index 000000000..085c0f047
--- /dev/null
+++ b/stdlib/source/lux/data/struct/set.lux
@@ -0,0 +1,85 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control functor
+                applicative
+                monad
+                eq
+                [hash #*])
+       (data (struct [dict]
+                     [list "List/" Fold Functor]))
+       (codata function)))
+
+## [Types]
+(type: #export (Set a)
+  (dict;Dict a a))
+
+## [Values]
+(def: #export (new Hash)
+  (All [a] (-> (Hash a) (Set a)))
+  (dict;new Hash))
+
+(def: #export (add elem set)
+  (All [a] (-> a (Set a) (Set a)))
+  (dict;put elem elem set))
+
+(def: #export (remove elem set)
+  (All [a] (-> a (Set a) (Set a)))
+  (dict;remove elem set))
+
+(def: #export (member? set elem)
+  (All [a] (-> (Set a) a Bool))
+  (dict;contains? elem set))
+
+(def: #export (union xs yx)
+  (All [a] (-> (Set a) (Set a) (Set a)))
+  (dict;merge xs yx))
+
+(def: #export (difference subs base)
+  (All [a] (-> (Set a) (Set a) (Set a)))
+  (List/fold remove base (dict;keys subs)))
+
+(def: #export (intersection filter base)
+  (All [a] (-> (Set a) (Set a) (Set a)))
+  (dict;select (dict;keys filter) base))
+
+(def: #export (size set)
+  (All [a] (-> (Set a) Nat))
+  (dict;size set))
+
+(def: #export (empty? set)
+  (All [a] (-> (Set a) Bool))
+  (=+ +0 (dict;size set)))
+
+(def: #export to-list
+  (All [a] (-> (Set a) (List a)))
+  dict;keys)
+
+(def: #export (from-list Hash xs)
+  (All [a] (-> (Hash a) (List a) (Set a)))
+  (List/fold add (new Hash) xs))
+
+(def: #export (sub? super sub)
+  (All [a] (-> (Set a) (Set a) Bool))
+  (list;every? (member? super) (to-list sub)))
+
+(def: #export (super? sub super)
+  (All [a] (-> (Set a) (Set a) Bool))
+  (sub? super sub))
+
+## [Structures]
+(struct: #export Eq (All [a] (Eq (Set a)))
+  (def: (= (^@ test [Hash _]) subject)
+    (:: (list;Eq (get@ #hash;eq Hash)) = (to-list test) (to-list subject))))
+
+(struct: #export Hash (All [a] (Hash (Set a)))
+  (def: eq Eq)
+  
+  (def: (hash (^@ set [Hash _]))
+    (List/fold (lambda [elem acc] (++ (:: Hash hash elem) acc))
+               +0
+               (to-list set))))
diff --git a/stdlib/source/lux/data/struct/stack.lux b/stdlib/source/lux/data/struct/stack.lux
new file mode 100644
index 000000000..e62a74590
--- /dev/null
+++ b/stdlib/source/lux/data/struct/stack.lux
@@ -0,0 +1,47 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (data (struct [list]))))
+
+## [Types]
+(type: #export (Stack a)
+  (List a))
+
+## [Values]
+(def: #export empty
+  Stack
+  (list))
+
+(def: #export (size stack)
+  (All [a] (-> (Stack a) Nat))
+  (list;size stack))
+
+(def: #export (empty? stack)
+  (All [a] (-> (Stack a) Bool))
+  (list;empty? stack))
+
+(def: #export (peek stack)
+  (All [a] (-> (Stack a) (Maybe a)))
+  (case stack
+    #;Nil
+    #;None
+    
+    (#;Cons value _)
+    (#;Some value)))
+
+(def: #export (pop stack)
+  (All [a] (-> (Stack a) (Stack a)))
+  (case stack
+    #;Nil
+    #;Nil
+    
+    (#;Cons _ stack')
+    stack'))
+
+(def: #export (push value stack)
+  (All [a] (-> a (Stack a) (Stack a)))
+  (#;Cons value stack))
diff --git a/stdlib/source/lux/data/struct/tree.lux b/stdlib/source/lux/data/struct/tree.lux
new file mode 100644
index 000000000..7b7828d73
--- /dev/null
+++ b/stdlib/source/lux/data/struct/tree.lux
@@ -0,0 +1,54 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monad
+                eq)
+       (data (struct [list "" Monad]))
+       [compiler]
+       (macro [ast]
+              ["s" syntax #+ syntax: Syntax])))
+
+## [Types]
+(type: #export (Tree a)
+  {#value a
+   #children (List (Tree a))})
+
+## [Values]
+(def: #export (flatten tree)
+  (All [a] (-> (Tree a) (List a)))
+  (#;Cons (get@ #value tree)
+          (join (map flatten (get@ #children tree)))))
+
+(def: #export (leaf value)
+  (All [a] (-> a (Tree a)))
+  {#value value
+   #children (list)})
+
+(def: #export (branch value children)
+  (All [a] (-> a (List (Tree a)) (Tree a)))
+  {#value value
+   #children children})
+
+## [Syntax]
+(type: #rec Tree-AST
+  [AST (List Tree-AST)])
+
+(def: (tree^ _)
+  (-> Unit (Syntax Tree-AST))
+  (s;record (s;seq s;any (s;tuple (s;some (lambda [state] ((tree^ []) state)))))))
+
+(syntax: #export (tree type {root (tree^ [])})
+  (wrap (list (` (: (Tree (~ type))
+                    (~ (loop [[value children] root]
+                         (` {#value (~ value)
+                             #children (list (~@ (map recur children)))}))))))))
+
+## [Structs]
+(struct: #export (Eq Eq) (All [a] (-> (Eq a) (Eq (Tree a))))
+  (def: (= tx ty)
+    (and (:: Eq = (get@ #value tx) (get@ #value ty))
+         (:: (list;Eq (Eq Eq)) = (get@ #children tx) (get@ #children ty)))))
diff --git a/stdlib/source/lux/data/struct/vector.lux b/stdlib/source/lux/data/struct/vector.lux
new file mode 100644
index 000000000..bb31063a4
--- /dev/null
+++ b/stdlib/source/lux/data/struct/vector.lux
@@ -0,0 +1,428 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control functor
+                applicative
+                monad
+                eq
+                monoid
+                fold)
+       (data maybe
+             (struct [list "List/" Fold Functor Monoid]
+                     [array #+ Array "Array/" Functor Fold])
+             [bit]
+             [number "Int/" Number]
+             [product])
+       [compiler #+ with-gensyms]
+       (macro [ast]
+              ["s" syntax #+ syntax: Syntax])
+       [pipe]
+       ))
+
+## This implementation of vectors is based on Clojure's
+## PersistentVector implementation.
+
+## [Utils]
+(type: (Node a)
+  (#Base (Array a))
+  (#Hierarchy (Array (Node a))))
+
+(type: (Base a) (Array a))
+(type: (Hierarchy a) (Array (Node a)))
+
+(type: Level Nat)
+
+(type: Index Nat)
+
+(def: branching-exponent
+  Nat
+  +5)
+
+(def: root-level
+  Level
+  +0)
+
+(do-template [ ]
+  [(def: 
+     (-> Level Level)
+     ( branching-exponent))]
+
+  [level-up   ++]
+  [level-down -+]
+  )
+
+(def: full-node-size
+  Nat
+  (bit;<< branching-exponent +1))
+
+(def: branch-idx-mask
+  Nat
+  (dec+ full-node-size))
+
+(def: branch-idx
+  (-> Index Index)
+  (bit;& branch-idx-mask))
+
+(def: (new-hierarchy _)
+  (All [a] (-> Top (Hierarchy a)))
+  (array;new full-node-size))
+
+(def: (tail-off vec-size)
+  (-> Nat Nat)
+  (if (<+ full-node-size vec-size)
+    +0
+    (|> (dec+ vec-size)
+        (bit;>>> branching-exponent)
+        (bit;<< branching-exponent))))
+
+(def: (new-path level tail)
+  (All [a] (-> Level (Base a) (Node a)))
+  (if (=+ +0 level)
+    (#Base tail)
+    (|> (: (Hierarchy ($ 0))
+           (new-hierarchy []))
+        (array;put +0 (new-path (level-down level) tail))
+        #Hierarchy)))
+
+(def: (new-tail singleton)
+  (All [a] (-> a (Base a)))
+  (|> (: (Base ($ 0))
+         (array;new +1))
+      (array;put +0 singleton)))
+
+(def: (push-tail size level tail parent)
+  (All [a] (-> Nat Level (Base a) (Hierarchy a) (Hierarchy a)))
+  (let [sub-idx (branch-idx (bit;>>> level (dec+ size)))
+        ## If we're currently on a bottom node
+        sub-node (if (=+ branching-exponent level)
+                   ## Just add the tail to it
+                   (#Base tail)
+                   ## Otherwise, check whether there's a vacant spot
+                   (case (array;get sub-idx parent)
+                     ## If so, set the path to the tail
+                     #;None
+                     (new-path (level-down level) tail)
+                     ## If not, push the tail onto the sub-node.
+                     (#;Some (#Hierarchy sub-node))
+                     (#Hierarchy (push-tail size (level-down level) tail sub-node))
+
+                     _
+                     (undefined))
+                   )]
+    (|> (array;clone parent)
+        (array;put sub-idx sub-node))))
+
+(def: (expand-tail val tail)
+  (All [a] (-> a (Base a) (Base a)))
+  (let [tail-size (array;size tail)]
+    (|> (: (Base ($ 0))
+           (array;new (inc+ tail-size)))
+        (array;copy tail-size +0 tail +0)
+        (array;put tail-size val)
+        )))
+
+(def: (put' level idx val hierarchy)
+  (All [a] (-> Level Index a (Hierarchy a) (Hierarchy a)))
+  (let [sub-idx (branch-idx (bit;>>> level idx))]
+    (case (array;get sub-idx hierarchy)
+      (#;Some (#Hierarchy sub-node))
+      (|> (array;clone hierarchy)
+          (array;put sub-idx (#Hierarchy (put' (level-down level) idx val sub-node))))
+
+      (^=> (#;Some (#Base base))
+           (=+ +0 (level-down level)))
+      (|> (array;clone hierarchy)
+          (array;put sub-idx (|> (array;clone base)
+                                 (array;put (branch-idx idx) val)
+                                 #Base)))
+
+      _
+      (undefined))))
+
+(def: (pop-tail size level hierarchy)
+  (All [a] (-> Nat Level (Hierarchy a) (Maybe (Hierarchy a))))
+  (let [sub-idx (branch-idx (bit;>>> level (-+ +2 size)))]
+    (cond (=+ +0 sub-idx)
+          #;None
+
+          (>+ branching-exponent level)
+          (do Monad
+            [base|hierarchy (array;get sub-idx hierarchy)
+             sub (case base|hierarchy
+                   (#Hierarchy sub)
+                   (pop-tail size (level-down level) sub)
+
+                   (#Base _)
+                   (undefined))]
+            (|> (array;clone hierarchy)
+                (array;put sub-idx (#Hierarchy sub))
+                #;Some))
+
+          ## Else...
+          (|> (array;clone hierarchy)
+              (array;remove sub-idx)
+              #;Some)
+          )))
+
+(def: (to-list' node)
+  (All [a] (-> (Node a) (List a)))
+  (case node
+    (#Base base)
+    (array;to-list base)
+    
+    (#Hierarchy hierarchy)
+    (|> hierarchy
+        array;to-list
+        list;reverse
+        (List/fold (lambda [sub acc] (List/append (to-list' sub) acc))
+                   #;Nil))))
+
+## [Types]
+(type: #export (Vector a)
+  {#level Level
+   #size Nat
+   #root (Hierarchy a)
+   #tail (Base a)})
+
+## [Exports]
+(def: #export empty
+  Vector
+  {#level (level-up root-level)
+   #size +0
+   #root (array;new full-node-size)
+   #tail (array;new +0)})
+
+(def: #export (size vector)
+  (All [a] (-> (Vector a) Nat))
+  (get@ #size vector))
+
+(def: #export (add val vec)
+  (All [a] (-> a (Vector a) (Vector a)))
+  ## Check if there is room in the tail.
+  (let [vec-size (get@ #size vec)]
+    (if (|> vec-size (-+ (tail-off vec-size)) (<+ full-node-size))
+      ## If so, append to it.
+      (|> vec
+          (update@ #size inc+)
+          (update@ #tail (expand-tail val)))
+      ## Otherwise, push tail into the tree
+      ## --------------------------------------------------------
+      ## Will the root experience an overflow with this addition?
+      (|> (if (>+ (bit;<< (get@ #level vec) +1)
+                  (bit;>>> branching-exponent vec-size))
+            ## If so, a brand-new root must be established, that is
+            ## 1-level taller.
+            (|> vec
+                (set@ #root (|> (: (Hierarchy ($ 0))
+                                   (new-hierarchy []))
+                                (array;put +0 (#Hierarchy (get@ #root vec)))
+                                (array;put +1 (new-path (get@ #level vec) (get@ #tail vec)))))
+                (update@ #level level-up))
+            ## Otherwise, just push the current tail onto the root.
+            (|> vec
+                (update@ #root (push-tail vec-size (get@ #level vec) (get@ #tail vec)))))
+          ## Finally, update the size of the Vector and grow a new
+          ## tail with the new element as it's sole member.
+          (update@ #size inc+)
+          (set@ #tail (new-tail val)))
+      )))
+
+(def: (base-for idx vec)
+  (All [a] (-> Index (Vector a) (Maybe (Base a))))
+  (let [vec-size (get@ #size vec)]
+    (if (and (>=+ +0 idx)
+             (<+ vec-size idx))
+      (if (>=+ (tail-off vec-size) idx)
+        (#;Some (get@ #tail vec))
+        (loop [level (get@ #level vec)
+               hierarchy (get@ #root vec)]
+          (case [(>+ branching-exponent level)
+                 (array;get (branch-idx (bit;>>> level idx)) hierarchy)]
+            [true (#;Some (#Hierarchy sub))]
+            (recur (level-down level) sub)
+
+            [false (#;Some (#Base base))]
+            (#;Some base)
+
+            [_ #;None]
+            #;None
+
+            _
+            (error! "Incorrect vector structure."))))
+      #;None)))
+
+(def: #export (at idx vec)
+  (All [a] (-> Nat (Vector a) (Maybe a)))
+  (do Monad
+    [base (base-for idx vec)]
+    (array;get (branch-idx idx) base)))
+
+(def: #export (put idx val vec)
+  (All [a] (-> Nat a (Vector a) (Vector a)))
+  (let [vec-size (get@ #size vec)]
+    (if (and (>=+ +0 idx)
+             (<+ vec-size idx))
+      (if (>=+ (tail-off vec-size) idx)
+        (|> vec
+            (update@ #tail (: (-> (Base ($ 0)) (Base ($ 0)))
+                              (|>. array;clone (array;put (branch-idx idx) val)))))
+        (|> vec
+            (update@ #root (put' (get@ #level vec) idx val))))
+      vec)))
+
+(def: #export (update idx f vec)
+  (All [a] (-> Nat (-> a a) (Vector a) (Vector a)))
+  (case (at idx vec)
+    (#;Some val)
+    (put idx (f val) vec)
+
+    #;None
+    vec))
+
+(def: #export (pop vec)
+  (All [a] (-> (Vector a) (Vector a)))
+  (case (get@ #size vec)
+    +0
+    empty
+
+    +1
+    empty
+
+    vec-size
+    (if (|> vec-size (-+ (tail-off vec-size)) (>+ +1))
+      (let [old-tail (get@ #tail vec)
+            new-tail-size (dec+ (array;size old-tail))]
+        (|> vec
+            (update@ #size dec+)
+            (set@ #tail (|> (array;new new-tail-size)
+                            (array;copy new-tail-size +0 old-tail +0)))))
+      (default (undefined)
+        (do Monad
+          [new-tail (base-for (-+ +2 vec-size) vec)
+           #let [[level' root'] (: [Level (Hierarchy ($ 0))]
+                                   (let [init-level (get@ #level vec)]
+                                     (loop [level init-level
+                                            root (: (Hierarchy ($ 0))
+                                                    (default (new-hierarchy [])
+                                                      (pop-tail vec-size init-level (get@ #root vec))))]
+                                       (if (>+ branching-exponent level)
+                                         (case [(array;get +1 root) (array;get +0 root)]
+                                           [#;None (#;Some (#Hierarchy sub-node))]
+                                           (recur (level-down level) sub-node)
+
+                                           [#;None (#;Some (#Base _))]
+                                           (undefined)
+
+                                           _
+                                           [level root])
+                                         [level root]))))]]
+          (wrap (|> vec
+                    (update@ #size dec+)
+                    (set@ #level level')
+                    (set@ #root root')
+                    (set@ #tail new-tail))))))
+    ))
+
+(def: #export (to-list vec)
+  (All [a] (-> (Vector a) (List a)))
+  (List/append (to-list' (#Hierarchy (get@ #root vec)))
+               (to-list' (#Base (get@ #tail vec)))))
+
+(def: #export (from-list list)
+  (All [a] (-> (List a) (Vector a)))
+  (List/fold add
+             (: (Vector ($ 0))
+                empty)
+             list))
+
+(def: #export (member? a/Eq vec val)
+  (All [a] (-> (Eq a) (Vector a) a Bool))
+  (list;member? a/Eq (to-list vec) val))
+
+(def: #export empty?
+  (All [a] (-> (Vector a) Bool))
+  (|>. (get@ #size) (=+ +0)))
+
+## [Syntax]
+(syntax: #export (vector {elems (s;some s;any)})
+  (wrap (list (` (from-list (list (~@ elems)))))))
+
+## [Structures]
+(struct: #export (Eq Eq) (All [a] (-> (Eq a) (Eq (Vector a))))
+  (def: (= v1 v2)
+    (:: (list;Eq Eq) = (to-list v1) (to-list v2))))
+
+(struct: _ (Fold Node)
+  (def: (fold f init xs)
+    (case xs
+      (#Base base)
+      (Array/fold f init base)
+      
+      (#Hierarchy hierarchy)
+      (Array/fold (lambda [node init'] (fold f init' node))
+                  init
+                  hierarchy))
+    ))
+
+(struct: #export _ (Fold Vector)
+  (def: (fold f init xs)
+    (let [(^open) Fold]
+      (fold f
+            (fold f
+                  init
+                  (#Hierarchy (get@ #root xs)))
+            (#Base (get@ #tail xs))))
+    ))
+
+(struct: #export Monoid (All [a]
+                                  (Monoid (Vector a)))
+  (def: unit empty)
+  (def: (append xs ys)
+    (List/fold add xs (to-list ys))))
+
+(struct: _ (Functor Node)
+  (def: (map f xs)
+    (case xs
+      (#Base base)
+      (#Base (Array/map f base))
+      
+      (#Hierarchy hierarchy)
+      (#Hierarchy (Array/map (map f) hierarchy)))
+    ))
+
+(struct: #export _ (Functor Vector)
+  (def: (map f xs)
+    {#level (get@ #level xs)
+     #size (get@ #size xs)
+     #root (|> xs (get@ #root) (Array/map (:: Functor map f)))
+     #tail (|> xs (get@ #tail) (Array/map f))
+     }))
+
+(struct: #export _ (Applicative Vector)
+  (def: functor Functor)
+
+  (def: (wrap x)
+    (vector x))
+  
+  (def: (apply ff fa)
+    (let [(^open) Functor
+          (^open) Fold
+          (^open) Monoid
+          results (map (lambda [f] (map f fa))
+                       ff)]
+      (fold append unit results)))
+  )
+
+(struct: #export _ (Monad Vector)
+  (def: applicative Applicative)
+
+  (def: (join ffa)
+    (let [(^open) Functor
+          (^open) Fold
+          (^open) Monoid]
+      (fold append unit ffa)))
+  )
diff --git a/stdlib/source/lux/data/struct/zipper.lux b/stdlib/source/lux/data/struct/zipper.lux
new file mode 100644
index 000000000..eb98409b4
--- /dev/null
+++ b/stdlib/source/lux/data/struct/zipper.lux
@@ -0,0 +1,196 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (data (struct [list "" Monad Fold "List/" Monoid]
+                     [tree #+ Tree]
+                     [stack #+ Stack]))
+       [compiler]
+       (macro [ast]
+              ["s" syntax #+ syntax: Syntax])))
+
+## Adapted from the clojure.zip namespace in the Clojure standard library.
+
+## [Types]
+(type: #export (Zipper a)
+  {#parent (Maybe (Zipper a))
+   #lefts (Stack (Tree a))
+   #rights (Stack (Tree a))
+   #node (Tree a)})
+
+## [Values]
+(def: #export (from-tree tree)
+  (All [a] (-> (Tree a) (Zipper a)))
+  {#parent #;None
+   #lefts stack;empty
+   #rights stack;empty
+   #node tree})
+
+(def: #export (to-tree zipper)
+  (All [a] (-> (Zipper a) (Tree a)))
+  (get@ #node zipper))
+
+(def: #export (value zipper)
+  (All [a] (-> (Zipper a) a))
+  (|> zipper (get@ #node) (get@ #tree;value)))
+
+(def: #export (children zipper)
+  (All [a] (-> (Zipper a) (List (Tree a))))
+  (|> zipper (get@ #node) (get@ #tree;children)))
+
+(def: #export (branch? zipper)
+  (All [a] (-> (Zipper a) Bool))
+  (|> zipper children list;empty? not))
+
+(def: #export (leaf? zipper)
+  (All [a] (-> (Zipper a) Bool))
+  (|> zipper branch? not))
+
+(def: #export (parent zipper)
+  (All [a] (-> (Zipper a) (Maybe (Zipper a))))
+  (get@ #parent zipper))
+
+(def: #export (down zipper)
+  (All [a] (-> (Zipper a) (Zipper a)))
+  (case (children zipper)
+    #;Nil
+    zipper
+
+    (#;Cons chead ctail)
+    {#parent (#;Some zipper)
+     #lefts stack;empty
+     #rights ctail
+     #node chead}))
+
+(def: #export (up zipper)
+  (All [a] (-> (Zipper a) (Zipper a)))
+  (case (get@ #parent zipper)
+    #;None
+    zipper
+
+    (#;Some parent)
+    (|> parent
+        (update@ #node (: (-> (Tree ($ 0)) (Tree ($ 0)))
+                          (lambda [node]
+                            (set@ #tree;children (List/append (list;reverse (get@ #lefts zipper))
+                                                              (#;Cons (get@ #node zipper)
+                                                                      (get@ #rights zipper)))
+                                  node)))))))
+
+(def: #export (root zipper)
+  (All [a] (-> (Zipper a) (Zipper a)))
+  (loop [zipper zipper]
+    (case (get@ #parent zipper)
+      #;None     zipper
+      (#;Some _) (recur (up zipper)))))
+
+(do-template [   ]
+  [(def: #export ( zipper)
+     (All [a] (-> (Zipper a) (Zipper a)))
+     (case (get@  zipper)
+       #;Nil
+       zipper
+
+       (#;Cons next side')
+       (|> zipper
+           (update@  (lambda [op-side]
+                                (#;Cons (get@ #node zipper) op-side)))
+           (set@  side')
+           (set@ #node next))))
+
+   (def: #export ( zipper)
+     (All [a] (-> (Zipper a) (Zipper a)))
+     (fold (lambda [_] ) zipper (get@  zipper)))]
+
+  [right rightmost #rights #lefts]
+  [left  leftmost  #lefts  #rights]
+  )
+
+(def: #export (set value zipper)
+  (All [a] (-> a (Zipper a) (Zipper a)))
+  (set@ [#node #tree;value] value zipper))
+
+(def: #export (update f zipper)
+  (All [a] (-> (-> a a) (Zipper a) (Zipper a)))
+  (update@ [#node #tree;value] f zipper))
+
+(def: #export (prepend-child value zipper)
+  (All [a] (-> a (Zipper a) (Zipper a)))
+  (update@ [#node #tree;children]
+           (lambda [children]
+             (#;Cons (tree;tree ($ 0) {value []})
+                     children))
+           zipper))
+
+(def: #export (append-child value zipper)
+  (All [a] (-> a (Zipper a) (Zipper a)))
+  (update@ [#node #tree;children]
+           (lambda [children]
+             (List/append children
+                          (list (tree;tree ($ 0) {value []}))))
+           zipper))
+
+(def: #export (remove zipper)
+  (All [a] (-> (Zipper a) (Maybe (Zipper a))))
+  (case (get@ #lefts zipper)
+    #;Nil
+    (case (get@ #parent zipper)
+      #;None
+      #;None
+
+      (#;Some next)
+      (#;Some (|> next
+                  (update@ [#node #tree;children] (|>. list;tail (default (list)))))))
+
+    (#;Cons next side)
+    (#;Some (|> zipper
+                (set@ #lefts side)
+                (set@ #node next)))))
+
+(do-template [ ]
+  [(def: #export ( value zipper)
+     (All [a] (-> a (Zipper a) (Maybe (Zipper a))))
+     (case (get@ #parent zipper)
+       #;None
+       #;None
+
+       _
+       (#;Some (|> zipper
+                   (update@  (lambda [side]
+                                     (#;Cons (tree;tree ($ 0) {value []})
+                                             side)))))))]
+
+  [insert-left  #lefts]
+  [insert-right #rights]
+  )
+
+(do-template [   ]
+  [(def: #export ( zipper)
+     (All [a] (-> (Zipper a) (Zipper a)))
+     (case (get@  zipper)
+       #;Nil
+       ( zipper)
+
+       _
+       ( zipper)))]
+
+  [next #rights right down]
+  [prev #lefts  left up]
+  )
+
+(def: #export (end? zipper)
+  (All [a] (-> (Zipper a) Bool))
+  (and (list;empty? (get@ #rights zipper))
+       (list;empty? (children zipper))))
+
+(def: #export (root? zipper)
+  (All [a] (-> (Zipper a) Bool))
+  (case (get@ #parent zipper)
+    #;None
+    true
+
+    _
+    false))
diff --git a/stdlib/source/lux/data/sum.lux b/stdlib/source/lux/data/sum.lux
new file mode 100644
index 000000000..f01d88727
--- /dev/null
+++ b/stdlib/source/lux/data/sum.lux
@@ -0,0 +1,45 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module: lux)
+
+## [Values]
+(do-template [  ]
+  [(def: #export ( value)
+     (All [a b] (->  (| a b)))
+     ( value))]
+
+  [left  a +0]
+  [right b +1])
+
+(def: #export (either f g s)
+  (All [a b c] (-> (-> a c) (-> b c) (| a b) c))
+  (case s
+    (+0 x)  (f x)
+    (+1 x) (g x)))
+
+(do-template [  ]
+  [(def: #export ( es)
+     (All [a b] (-> (List (| a b)) (List )))
+     (case es
+       #;Nil                  #;Nil
+       (#;Cons ( x) es') (#;Cons [x ( es')])
+       (#;Cons _ es')         ( es')))]
+
+  [lefts  a +0]
+  [rights b +1]
+  )
+
+(def: #export (partition xs)
+  (All [a b] (-> (List (| a b)) [(List a) (List b)]))
+  (case xs
+    #;Nil
+    [#;Nil #;Nil]
+
+    (#;Cons x xs')
+    (let [[lefts rights] (partition xs')]
+      (case x
+        (+0 x')  [(#;Cons x' lefts) rights]
+        (+1 x') [lefts (#;Cons x' rights)]))))
diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux
new file mode 100644
index 000000000..97507ba3b
--- /dev/null
+++ b/stdlib/source/lux/data/text.lux
@@ -0,0 +1,223 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monoid
+                eq
+                [ord]
+                monad
+                codec
+                hash)
+       (data (struct [list])
+             maybe)))
+
+## [Functions]
+(def: #export (size x)
+  (-> Text Nat)
+  (int-to-nat (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])])))
+
+(def: #export (at idx x)
+  (-> Nat Text (Maybe Char))
+  (if (<+ (size x) idx)
+    (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:charAt:int"] [x (_lux_proc ["jvm" "l2i"] [(nat-to-int idx)])]))
+    #;None))
+
+(def: #export (contains? sub text)
+  (-> Text Text Bool)
+  (_lux_proc ["jvm" "invokevirtual:java.lang.String:contains:java.lang.CharSequence"] [text sub]))
+
+(do-template [ ]
+  [(def: #export ( x)
+     (-> Text Text)
+     (_lux_proc ["jvm" ] [x]))]
+  [lower-case "invokevirtual:java.lang.String:toLowerCase:"]
+  [upper-case "invokevirtual:java.lang.String:toUpperCase:"]
+  [trim       "invokevirtual:java.lang.String:trim:"]
+  )
+
+(def: #export (sub from to x)
+  (-> Nat Nat Text (Maybe Text))
+  (if (and (<+ to from)
+           (<=+ (size x) to))
+    (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"]
+                       [x
+                        (_lux_proc ["jvm" "l2i"] [(nat-to-int from)])
+                        (_lux_proc ["jvm" "l2i"] [(nat-to-int to)])]))
+    #;None))
+
+(def: #export (sub' from x)
+  (-> Nat Text (Maybe Text))
+  (sub from (size x) x))
+
+(def: #export (replace pattern value template)
+  (-> Text Text Text Text)
+  (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value]))
+
+(do-template [   ]
+  [(def: #export ( pattern x)
+     (-> Text Text (Maybe Nat))
+     (case (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" ] [x pattern])])
+       -1  #;None
+       idx (#;Some (int-to-nat idx))))
+
+   (def: #export ( pattern from x)
+     (-> Text Nat Text (Maybe Nat))
+     (if (<+ (size x) from)
+       (case (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" ] [x pattern (_lux_proc ["jvm" "l2i"] [(nat-to-int from)])])])
+         -1  #;None
+         idx (#;Some (int-to-nat idx)))
+       #;None))]
+
+  [index-of      "invokevirtual:java.lang.String:indexOf:java.lang.String"     index-of'      "invokevirtual:java.lang.String:indexOf:java.lang.String,int"]
+  [last-index-of "invokevirtual:java.lang.String:lastIndexOf:java.lang.String" last-index-of' "invokevirtual:java.lang.String:lastIndexOf:java.lang.String,int"]
+  )
+
+(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)
+    (=+ (size x)
+        (++ (size postfix) n))
+
+    _
+    false))
+
+(def: #export (split at x)
+  (-> Nat Text (Maybe [Text Text]))
+  (if (<=+ (size x) at)
+    (let [pre (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] [x (_lux_proc ["jvm" "l2i"] [0]) (_lux_proc ["jvm" "l2i"] [(nat-to-int at)])])
+          post (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int"] [x (_lux_proc ["jvm" "l2i"] [(nat-to-int at)])])]
+      (#;Some [pre post]))
+    #;None))
+
+(def: #export (split-with token sample)
+  (-> Text Text (Maybe [Text Text]))
+  (do Monad
+    [index (index-of token sample)
+     [pre post'] (split index sample)
+     [_ post] (split (size token) post')]
+    (wrap [pre post])))
+
+(def: #export (split-all-with token sample)
+  (-> Text Text (List Text))
+  (case (split-with token sample)
+    (#;Some [pre post])
+    (#;Cons pre (split-all-with token post))
+
+    #;None
+    (#;Cons sample #;Nil)))
+
+(def: #export split-lines
+  (split-all-with "\n"))
+
+## [Structures]
+(struct: #export _ (Eq Text)
+  (def: (= test subject)
+    (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [subject test])))
+
+(struct: #export _ (ord;Ord Text)
+  (def: eq Eq)
+
+  (do-template [ ]
+    [(def: ( test subject)
+       ( 0
+             (_lux_proc ["jvm" "i2l"]  [(_lux_proc ["jvm" "invokevirtual:java.lang.String:compareTo:java.lang.String"] [subject test])])))]
+
+    [<  ;<]
+    [<= ;<=]
+    [>  ;>]
+    [>= ;>=]))
+
+(struct: #export _ (Monoid Text)
+  (def: unit "")
+  (def: (append x y)
+    (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [x y])))
+
+(open Monoid)
+
+(struct: #export _ (Codec Text Text)
+  (def: (encode original)
+    (let [escaped (|> original
+                      (replace "\\" "\\\\")
+                      (replace "\t" "\\t")
+                      (replace "\b" "\\b")
+                      (replace "\n" "\\n")
+                      (replace "\r" "\\r")
+                      (replace "\f" "\\f")
+                      (replace "\"" "\\\"")
+                      )]
+      ($_ append "\"" escaped "\"")))
+
+  (def: (decode input)
+    (if (and (starts-with? "\"" input)
+             (ends-with? "\"" input))
+      (case (sub +1 (dec+ (size input)) input)
+        (#;Some input')
+        (|> input'
+            (replace "\\\\" "\\")
+            (replace "\\t" "\t")
+            (replace "\\b" "\b")
+            (replace "\\n" "\n")
+            (replace "\\r" "\r")
+            (replace "\\f" "\f")
+            (replace "\\\"" "\"")
+            #;Some)
+
+        #;None
+        (#;Left "Couldn't decode text"))
+      (#;Left "Couldn't decode text"))))
+
+(struct: #export _ (Hash Text)
+  (def: eq Eq)
+  
+  (def: hash
+    (|>. []
+         (_lux_proc ["jvm" "invokevirtual:java.lang.Object:hashCode:"])
+         []
+         (_lux_proc ["jvm" "i2l"])
+         int-to-nat)))
+
+(def: #export concat
+  (-> (List Text) Text)
+  (let [(^open) list;Fold
+        (^open) Monoid]
+    (|>. list;reverse (fold append unit))))
+
+(def: #export (join-with sep texts)
+  (-> Text (List Text) Text)
+  (|> texts (list;interpose sep) concat))
+
+(def: #export (empty? text)
+  (-> Text Bool)
+  (case text
+    "" true
+    _  false))
+
+(def: #export (replace-once pattern value template)
+  (-> Text Text Text Text)
+  (default template
+    (do Monad
+      [[pre post] (split-with pattern template)]
+      (let [(^open) Monoid]
+        (wrap ($_ append pre value post))))))
+
+(def: #export (enclose [left right] content)
+  (-> [Text Text] Text Text)
+  (let [(^open) Monoid]
+    ($_ append left content right)))
+
+(def: #export (enclose' boundary content)
+  (-> Text Text Text)
+  (enclose [boundary boundary] content))
diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux
new file mode 100644
index 000000000..a8b289fe3
--- /dev/null
+++ b/stdlib/source/lux/data/text/format.lux
@@ -0,0 +1,54 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monad)
+       (data [bool]
+             [char]
+             [number]
+             [text]
+             [ident]
+             (struct [list "" Monad]))
+       [type]
+       [compiler]
+       (macro [ast]
+              ["s" syntax #+ syntax: Syntax])))
+
+## [Syntax]
+(def: #hidden _append_
+  (-> Text Text Text)
+  (:: text;Monoid append))
+
+(syntax: #export (format {fragments (s;many s;any)})
+  {#;doc (doc "Text interpolation as a macro."
+              (format "Static part " (%t static) " doesn't match URI: " uri))}
+  (wrap (list (` ($_ _append_ (~@ fragments))))))
+
+## [Formatters]
+(type: (Formatter a)
+  (-> a Text))
+
+(do-template [  ]
+  [(def: #export 
+     (Formatter )
+     )]
+
+  [%b     Bool  (:: bool;Codec encode)]
+  [%n     Nat   (:: number;Codec encode)]
+  [%i     Int   (:: number;Codec encode)]
+  [%f     Frac  (:: number;Codec encode)]
+  [%r     Real  (:: number;Codec encode)]
+  [%c     Char  (:: char;Codec encode)]
+  [%t     Text  (:: text;Codec encode)]
+  [%ident Ident (:: ident;Codec encode)]
+  [%ast   AST   ast;ast-to-text]
+  [%type  Type  type;type-to-text]
+  )
+
+(def: #export (%list formatter)
+  (All [a] (-> (Formatter a) (Formatter (List a))))
+  (lambda [values]
+    (format "(list " (text;join-with " " (map formatter values)) ")")))
diff --git a/stdlib/source/lux/host.lux b/stdlib/source/lux/host.lux
new file mode 100644
index 000000000..ecc33227a
--- /dev/null
+++ b/stdlib/source/lux/host.lux
@@ -0,0 +1,2137 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monad
+                [enum])
+       (codata function
+               [io #+ IO Monad io])
+       (data (struct [list #* "" Functor Fold "List/" Monad Monoid]
+                     [array #+ Array])
+             number
+             maybe
+             [product]
+             [text "Text/" Eq]
+             text/format
+             [bool "Bool/" Codec])
+       [compiler #+ with-gensyms Functor Monad]
+       (macro [ast]
+              ["s" syntax #+ syntax: Syntax])
+       [type]
+       ))
+
+(do-template [   ]
+  [(def: #export ( value)
+     {#;doc (doc "Type converter."
+                 "From:"
+                 
+                 "To:"
+                 )}
+     (-> (host ) (host ))
+     (_lux_proc ["jvm" ] [value]))]
+
+  [b2l "b2l" java.lang.Byte      java.lang.Long]
+
+  [s2l "s2l" java.lang.Short     java.lang.Long]
+  
+  [d2i "d2i" java.lang.Double    java.lang.Integer]
+  [d2l "d2l" java.lang.Double    java.lang.Long]
+  [d2f "d2f" java.lang.Double    java.lang.Float]
+
+  [f2i "f2i" java.lang.Float     java.lang.Integer]
+  [f2l "f2l" java.lang.Float     java.lang.Long]
+  [f2d "f2d" java.lang.Float     java.lang.Double]
+  
+  [i2b "i2b" java.lang.Integer   java.lang.Byte]
+  [i2s "i2s" java.lang.Integer   java.lang.Short]
+  [i2l "i2l" java.lang.Integer   java.lang.Long]
+  [i2f "i2f" java.lang.Integer   java.lang.Float]
+  [i2d "i2d" java.lang.Integer   java.lang.Double]
+  [i2c "i2c" java.lang.Integer   java.lang.Character]
+
+  [l2b "l2b" java.lang.Long      java.lang.Byte]
+  [l2s "l2s" java.lang.Long      java.lang.Short]
+  [l2i "l2i" java.lang.Long      java.lang.Integer]
+  [l2f "l2f" java.lang.Long      java.lang.Float]
+  [l2d "l2d" java.lang.Long      java.lang.Double]
+
+  [c2b "c2b" java.lang.Character java.lang.Byte]
+  [c2s "c2s" java.lang.Character java.lang.Short]
+  [c2i "c2i" java.lang.Character java.lang.Integer]
+  [c2l "c2l" java.lang.Character java.lang.Long]
+  )
+
+## [Utils]
+(def: array-type-name "#Array")
+(def: constructor-method-name "")
+(def: member-separator ".")
+
+## Types
+(do-template [ ]
+  [(type: #export 
+     (#;HostT  #;Nil))]
+
+  ["[Z" BooleanArray]
+  ["[B" ByteArray]
+  ["[S" ShortArray]
+  ["[I" IntArray]
+  ["[J" LongArray]
+  ["[F" FloatArray]
+  ["[D" DoubleArray]
+  ["[C" CharArray]
+  )
+
+(type: Code Text)
+
+(type: BoundKind
+  #UpperBound
+  #LowerBound)
+
+(type: #rec GenericType
+  (#GenericTypeVar Text)
+  (#GenericClass [Text (List GenericType)])
+  (#GenericArray GenericType)
+  (#GenericWildcard (Maybe [BoundKind GenericType])))
+
+(type: TypeParam
+  [Text (List GenericType)])
+
+(type: Primitive-Mode
+  #ManualPrM
+  #AutoPrM)
+
+(type: PrivacyModifier
+  #PublicPM
+  #PrivatePM
+  #ProtectedPM
+  #DefaultPM)
+
+(type: StateModifier
+  #VolatileSM
+  #FinalSM
+  #DefaultSM)
+
+(type: InheritanceModifier
+  #FinalIM
+  #AbstractIM
+  #DefaultIM)
+
+(type: ClassKind
+  #Class
+  #Interface)
+
+(type: ClassDecl
+  {#class-name   Text
+   #class-params (List TypeParam)})
+
+(type: StackFrame (host java.lang.StackTraceElement))
+(type: StackTrace (Array StackFrame))
+
+(type: SuperClassDecl
+  {#super-class-name   Text
+   #super-class-params (List GenericType)})
+
+(type: AnnotationParam
+  [Text AST])
+
+(type: Annotation
+  {#ann-name   Text
+   #ann-params (List AnnotationParam)})
+
+(type: MemberDecl
+  {#member-name Text
+   #member-privacy PrivacyModifier
+   #member-anns (List Annotation)})
+
+(type: FieldDecl
+  (#ConstantField GenericType AST)
+  (#VariableField StateModifier GenericType))
+
+(type: MethodDecl
+  {#method-tvars  (List TypeParam)
+   #method-inputs (List GenericType)
+   #method-output GenericType
+   #method-exs    (List GenericType)})
+
+(type: ArgDecl
+  {#arg-name Text
+   #arg-type GenericType})
+
+(type: ConstructorArg
+  [GenericType AST])
+
+(type: MethodDef
+  (#ConstructorMethod [Bool
+                       (List TypeParam)
+                       (List ArgDecl)
+                       (List ConstructorArg)
+                       AST
+                       (List GenericType)])
+  (#VirtualMethod [Bool
+                   Bool
+                   (List TypeParam)
+                   (List ArgDecl)
+                   GenericType
+                   AST
+                   (List GenericType)])
+  (#OverridenMethod [Bool
+                     ClassDecl
+                     (List TypeParam)
+                     (List ArgDecl)
+                     GenericType
+                     AST
+                     (List GenericType)])
+  (#StaticMethod [Bool
+                  (List TypeParam)
+                  (List ArgDecl)
+                  GenericType
+                  AST
+                  (List GenericType)])
+  (#AbstractMethod [(List TypeParam)
+                    (List ArgDecl)
+                    GenericType
+                    (List GenericType)])
+  (#NativeMethod [(List TypeParam)
+                  (List ArgDecl)
+                  GenericType
+                  (List GenericType)]))
+
+(type: PartialCall
+  {#pc-method AST
+   #pc-args   AST})
+
+(type: ImportMethodKind
+  #StaticIMK
+  #VirtualIMK)
+
+(type: ImportMethodCommons
+  {#import-member-mode   Primitive-Mode
+   #import-member-alias  Text
+   #import-member-kind   ImportMethodKind
+   #import-member-tvars  (List TypeParam)
+   #import-member-args   (List [Bool GenericType])
+   #import-member-maybe? Bool
+   #import-member-try?   Bool
+   #import-member-io?    Bool})
+
+(type: ImportConstructorDecl
+  {})
+
+(type: ImportMethodDecl
+  {#import-method-name    Text
+   #import-method-return  GenericType})
+
+(type: ImportFieldDecl
+  {#import-field-mode    Primitive-Mode
+   #import-field-name    Text
+   #import-field-static? Bool
+   #import-field-maybe?  Bool
+   #import-field-setter? Bool
+   #import-field-type    GenericType})
+
+(type: ImportMemberDecl
+  (#EnumDecl        (List Text))
+  (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl])
+  (#MethodDecl      [ImportMethodCommons ImportMethodDecl])
+  (#FieldAccessDecl ImportFieldDecl))
+
+(type: ClassImports
+  (List [Text Text]))
+
+## Utils
+(def: (short-class-name name)
+  (-> Text Text)
+  (case (reverse (text;split-all-with "." name))
+    (#;Cons short-name _)
+    short-name
+
+    #;Nil
+    name))
+
+(def: (manual-primitive-to-type class)
+  (-> Text (Maybe AST))
+  (case class
+    (^template [ ]
+      
+      (#;Some (' )))
+    (["boolean" (;^ java.lang.Boolean)]
+     ["byte"    (;^ java.lang.Byte)]
+     ["short"   (;^ java.lang.Short)]
+     ["int"     (;^ java.lang.Integer)]
+     ["long"    (;^ java.lang.Long)]
+     ["float"   (;^ java.lang.Float)]
+     ["double"  (;^ java.lang.Double)]
+     ["char"    (;^ java.lang.Character)]
+     ["void"    ;Unit])
+
+    _
+    #;None))
+
+(def: (auto-primitive-to-type class)
+  (-> Text (Maybe AST))
+  (case class
+    (^template [ ]
+      
+      (#;Some (' )))
+    (["boolean" ;Bool]
+     ["byte"    ;Int]
+     ["short"   ;Int]
+     ["int"     ;Int]
+     ["long"    ;Int]
+     ["float"   ;Real]
+     ["double"  ;Real]
+     ["char"    ;Char]
+     ["void"    ;Unit])
+
+    _
+    #;None))
+
+(def: (generic-class->type' mode type-params in-array? name+params
+                            class->type')
+  (-> Primitive-Mode (List TypeParam) Bool [Text (List GenericType)]
+      (-> Primitive-Mode (List TypeParam) Bool GenericType AST)
+      AST)
+  (case [name+params mode in-array?]
+    (^=> [[prim #;Nil] #ManualPrM false]
+         {(manual-primitive-to-type prim) (#;Some output)})
+    output
+
+    (^=> [[prim #;Nil] #AutoPrM false]
+         {(auto-primitive-to-type prim) (#;Some output)})
+    output
+    
+    [[name params] _ _]
+    (let [=params (map (class->type' mode type-params in-array?) params)]
+      (` (host (~ (ast;symbol ["" name])) [(~@ =params)])))))
+
+(def: (class->type' mode type-params in-array? class)
+  (-> Primitive-Mode (List TypeParam) Bool GenericType AST)
+  (case class
+    (#GenericTypeVar name)
+    (case (find (lambda [[pname pbounds]]
+                  (and (Text/= name pname)
+                       (not (list;empty? pbounds))))
+                type-params)
+      #;None
+      (ast;symbol ["" name])
+
+      (#;Some [pname pbounds])
+      (class->type' mode type-params in-array? (default (undefined) (list;head pbounds))))
+    
+    (#GenericClass name+params)
+    (generic-class->type' mode type-params in-array? name+params
+                          class->type')
+
+    (#GenericArray param)
+    (let [=param (class->type' mode type-params true param)]
+      (` (host (~ (ast;symbol ["" array-type-name])) [(~ =param)])))
+
+    (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _])))
+    (' (;Ex [*] *))
+
+    (#GenericWildcard (#;Some [#UpperBound upper-bound]))
+    (class->type' mode type-params in-array? upper-bound)
+    ))
+
+(def: (class->type mode type-params class)
+  (-> Primitive-Mode (List TypeParam) GenericType AST)
+  (class->type' mode type-params false class))
+
+(def: (type-param-type$ [name bounds])
+  (-> TypeParam AST)
+  (ast;symbol ["" name]))
+
+(def: (class-decl-type$ (^slots [#class-name #class-params]))
+  (-> ClassDecl AST)
+  (let [=params (map (: (-> TypeParam AST)
+                        (lambda [[pname pbounds]]
+                          (case pbounds
+                            #;Nil
+                            (ast;symbol ["" pname])
+
+                            (#;Cons bound1 _)
+                            (class->type #ManualPrM class-params bound1))))
+                     class-params)]
+    (` (host (~ (ast;symbol ["" class-name])) [(~@ =params)]))))
+
+(def: (stack-trace->text trace)
+  (-> StackTrace Text)
+  (let [size (_lux_proc ["jvm" "arraylength"] [trace])
+        idxs (list;range+ +0 (dec+ size))]
+    (|> idxs
+        (map (: (-> Nat Text)
+                (lambda [idx]
+                  (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"]
+                             [(_lux_proc ["jvm" "aaload"] [trace idx])]))))
+        reverse
+        (text;join-with "\n")
+        )))
+
+(def: (get-stack-trace t)
+  (-> (host java.lang.Throwable) StackTrace)
+  (_lux_proc ["jvm" "invokevirtual:java.lang.Throwable:getStackTrace:"] [t]))
+
+(def: #export (throwable->text t)
+  (All [a] (-> (host java.lang.Throwable) (Either Text a)))
+  (#;Left (format (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [t])
+                  "\n"
+                  (|> t get-stack-trace stack-trace->text))))
+
+(def: empty-imports
+  ClassImports
+  (list))
+
+(def: (get-import name imports)
+  (-> Text ClassImports (Maybe Text))
+  (:: Functor map product;right
+      (find (|>. product;left (Text/= name))
+            imports)))
+
+(def: (add-import short+full imports)
+  (-> [Text Text] ClassImports ClassImports)
+  (#;Cons short+full imports))
+
+(def: (class-imports compiler)
+  (-> Compiler ClassImports)
+  (case (compiler;run compiler
+                      (: (Lux ClassImports)
+                         (do Monad
+                           [current-module compiler;current-module-name
+                            defs (compiler;defs current-module)]
+                           (wrap (fold (: (-> [Text Def] ClassImports ClassImports)
+                                          (lambda [[short-name [_ meta _]] imports]
+                                            (case (compiler;get-text-ann (ident-for #;;jvm-class) meta)
+                                              (#;Some full-class-name)
+                                              (add-import [short-name full-class-name] imports)
+
+                                              _
+                                              imports)))
+                                       empty-imports
+                                       defs)))))
+    (#;Left _)        (list)
+    (#;Right imports) imports))
+
+(def: java.lang-classes
+  (List Text)
+  (list ## Interfaces
+   "Appendable"
+   "AutoCloseable"
+   "CharSequence"
+   "Cloneable"
+   "Comparable"
+   "Iterable"
+   "Readable"
+   "Runnable"
+
+   ## Classes
+   "Boolean"
+   "Byte"
+   "Character"
+   "Class"
+   "ClassLoader"
+   "ClassValue"
+   "Compiler"
+   "Double"
+   "Enum"
+   "Float"
+   "InheritableThreadLocal"
+   "Integer"
+   "Long"
+   "Math"
+   "Number"
+   "Object"
+   "Package"
+   "Process"
+   "ProcessBuilder"
+   "Runtime"
+   "RuntimePermission"
+   "SecurityManager"
+   "Short"
+   "StackTraceElement"
+   "StrictMath"
+   "String"
+   "StringBuffer"
+   "StringBuilder"
+   "System"
+   "Thread"
+   "ThreadGroup"
+   "ThreadLocal"
+   "Throwable"
+   "Void"
+
+   ## Exceptions
+   "ArithmeticException"
+   "ArrayIndexOutOfBoundsException"
+   "ArrayStoreException"
+   "ClassCastException"
+   "ClassNotFoundException"
+   "CloneNotSupportedException"
+   "EnumConstantNotPresentException"
+   "Exception"
+   "IllegalAccessException"
+   "IllegalArgumentException"
+   "IllegalMonitorStateException"
+   "IllegalStateException"
+   "IllegalThreadStateException"
+   "IndexOutOfBoundsException"
+   "InstantiationException"
+   "InterruptedException"
+   "NegativeArraySizeException"
+   "NoSuchFieldException"
+   "NoSuchMethodException"
+   "NullPointerException"
+   "NumberFormatException"
+   "ReflectiveOperationException"
+   "RuntimeException"
+   "SecurityException"
+   "StringIndexOutOfBoundsException"
+   "TypeNotPresentException"
+   "UnsupportedOperationException"
+
+   ## Annotations
+   "Deprecated"
+   "Override"
+   "SafeVarargs"
+   "SuppressWarnings"))
+
+(def: (fully-qualified-class-name? name)
+  (-> Text Bool)
+  (text;contains? "." name))
+
+(def: (fully-qualify-class-name imports name)
+  (-> ClassImports Text Text)
+  (cond (fully-qualified-class-name? name)
+        name
+
+        (member? text;Eq java.lang-classes name)
+        (format "java.lang." name)
+
+        ## else
+        (default name (get-import name imports))))
+
+(def: type-var-class Text "java.lang.Object")
+
+(def: (simple-class$ params class)
+  (-> (List TypeParam) GenericType Text)
+  (case class
+    (#GenericTypeVar name)
+    (case (find (lambda [[pname pbounds]]
+                  (and (Text/= name pname)
+                       (not (list;empty? pbounds))))
+                params)
+      #;None
+      type-var-class
+
+      (#;Some [pname pbounds])
+      (simple-class$ params (default (undefined) (list;head pbounds))))
+
+    (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _])))
+    type-var-class
+    
+    (#GenericWildcard (#;Some [#UpperBound upper-bound]))
+    (simple-class$ params upper-bound)
+    
+    (#GenericClass name params)
+    name
+
+    (#GenericArray param')
+    (case param'
+      (#GenericArray param)
+      (format "[" (simple-class$ params param))
+      
+      (^template [ ]
+        (#GenericClass  #;Nil)
+        )
+      (["boolean" "[Z"]
+       ["byte"    "[B"]
+       ["short"   "[S"]
+       ["int"     "[I"]
+       ["long"    "[J"]
+       ["float"   "[F"]
+       ["double"  "[D"]
+       ["char"    "[C"])
+      
+      param
+      (format "[L" (simple-class$ params param) ";"))
+    ))
+
+(def: (make-get-const-parser class-name field-name)
+  (-> Text Text (Syntax AST))
+  (do s;Monad
+    [#let [dotted-name (format "." field-name)]
+     _ (s;symbol! ["" dotted-name])]
+    (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" class-name ":" field-name)))] [])))))
+
+(def: (make-get-var-parser class-name field-name)
+  (-> Text Text (Syntax AST))
+  (do s;Monad
+    [#let [dotted-name (format "." field-name)]
+     _ (s;symbol! ["" dotted-name])]
+    (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" class-name ":" field-name)))] [_jvm_this])))))
+
+(def: (make-put-var-parser class-name field-name)
+  (-> Text Text (Syntax AST))
+  (do s;Monad
+    [#let [dotted-name (format "." field-name)]
+     [_ _ value] (: (Syntax [Unit Unit AST])
+                    (s;form ($_ s;seq (s;symbol! ["" ":="]) (s;symbol! ["" dotted-name]) s;any)))]
+    (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "putfield" ":" class-name ":" field-name)))] [_jvm_this (~ value)])))))
+
+(def: (pre-walk-replace f input)
+  (-> (-> AST AST) AST AST)
+  (case (f input)
+    (^template []
+      [meta ( parts)]
+      [meta ( (map (pre-walk-replace f) parts))])
+    ([#;FormS]
+     [#;TupleS])
+    
+    [meta (#;RecordS pairs)]
+    [meta (#;RecordS (map (: (-> [AST AST] [AST AST])
+                             (lambda [[key val]]
+                               [(pre-walk-replace f key) (pre-walk-replace f val)]))
+                          pairs))]
+    
+    ast'
+    ast'))
+
+(def: (parser->replacer p ast)
+  (-> (Syntax AST) (-> AST AST))
+  (case (s;run (list ast) p)
+    (#;Right [#;Nil ast'])
+    ast'
+
+    _
+    ast
+    ))
+
+(def: (field->parser class-name [[field-name _ _] field])
+  (-> Text [MemberDecl FieldDecl] (Syntax AST))
+  (case field
+    (#ConstantField _)
+    (make-get-const-parser class-name field-name)
+    
+    (#VariableField _)
+    (s;either (make-get-var-parser class-name field-name)
+              (make-put-var-parser class-name field-name))))
+
+(def: (make-constructor-parser params class-name arg-decls)
+  (-> (List TypeParam) Text (List ArgDecl) (Syntax AST))
+  (do s;Monad
+    [[_ args] (: (Syntax [Unit (List AST)])
+                 (s;form ($_ s;seq (s;symbol! ["" ".new!"]) (s;tuple (s;exactly (list;size arg-decls) s;any)))))
+     #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]]
+    (wrap (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" class-name ":" (text;join-with "," arg-decls'))))]
+                         [(~@ args)])))))
+
+(def: (make-static-method-parser params class-name method-name arg-decls)
+  (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST))
+  (do s;Monad
+    [#let [dotted-name (format "." method-name "!")]
+     [_ args] (: (Syntax [Unit (List AST)])
+                 (s;form ($_ s;seq (s;symbol! ["" dotted-name]) (s;tuple (s;exactly (list;size arg-decls) s;any)))))
+     #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]]
+    (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokestatic" ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))]
+                          [(~@ args)])))))
+
+(do-template [ ]
+  [(def: ( params class-name method-name arg-decls)
+     (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST))
+     (do s;Monad
+       [#let [dotted-name (format "." method-name "!")]
+        [_ args] (: (Syntax [Unit (List AST)])
+                    (s;form ($_ s;seq (s;symbol! ["" dotted-name]) (s;tuple (s;exactly (list;size arg-decls) s;any)))))
+        #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]]
+       (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format  ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))]
+                             [(~' _jvm_this) (~@ args)])))))]
+
+  [make-special-method-parser "invokespecial"]
+  [make-virtual-method-parser "invokevirtual"]
+  )
+
+(def: (method->parser params class-name [[method-name _ _] meth-def])
+  (-> (List TypeParam) Text [MemberDecl MethodDef] (Syntax AST))
+  (case meth-def
+    (#ConstructorMethod strict? type-vars args constructor-args return-expr exs)
+    (make-constructor-parser params class-name args)
+    
+    (#StaticMethod strict? type-vars args return-type return-expr exs)
+    (make-static-method-parser params class-name method-name args)
+    
+    (^or (#VirtualMethod final? strict? type-vars args return-type return-expr exs) (#OverridenMethod strict? owner-class type-vars args return-type return-expr exs))
+    (make-special-method-parser params class-name method-name args)
+
+    (#AbstractMethod type-vars args return-type exs)
+    (make-virtual-method-parser params class-name method-name args)
+
+    (#NativeMethod type-vars args return-type exs)
+    (make-virtual-method-parser params class-name method-name args)))
+
+## Syntaxs
+(def: (full-class-name^ imports)
+  (-> ClassImports (Syntax Text))
+  (do s;Monad
+    [name s;local-symbol]
+    (wrap (fully-qualify-class-name imports name))))
+
+(def: privacy-modifier^
+  (Syntax PrivacyModifier)
+  (let [(^open) s;Monad]
+    ($_ s;alt
+        (s;tag! ["" "public"])
+        (s;tag! ["" "private"])
+        (s;tag! ["" "protected"])
+        (wrap []))))
+
+(def: inheritance-modifier^
+  (Syntax InheritanceModifier)
+  (let [(^open) s;Monad]
+    ($_ s;alt
+        (s;tag! ["" "final"])
+        (s;tag! ["" "abstract"])
+        (wrap []))))
+
+(def: bound-kind^
+  (Syntax BoundKind)
+  (s;alt (s;symbol! ["" "<"])
+         (s;symbol! ["" ">"])))
+
+(def: (generic-type^ imports type-vars)
+  (-> ClassImports (List TypeParam) (Syntax GenericType))
+  ($_ s;either
+      (do s;Monad
+        [_ (s;symbol! ["" "?"])]
+        (wrap (#GenericWildcard #;None)))
+      (s;tuple (do s;Monad
+                 [_ (s;symbol! ["" "?"])
+                  bound-kind bound-kind^
+                  bound (generic-type^ imports type-vars)]
+                 (wrap (#GenericWildcard (#;Some [bound-kind bound])))))
+      (do s;Monad
+        [name (full-class-name^ imports)]
+        (let% [ (do-template [ ]
+                            [(Text/=  name)
+                             (wrap (#GenericClass  (list)))]
+
+                            ["[Z" "BooleanArray"]
+                            ["[B" "ByteArray"]
+                            ["[S" "ShortArray"]
+                            ["[I" "IntArray"]
+                            ["[J" "LongArray"]
+                            ["[F" "FloatArray"]
+                            ["[D" "DoubleArray"]
+                            ["[C" "CharArray"])]
+          (cond (member? text;Eq (map product;left type-vars) name)
+                (wrap (#GenericTypeVar name))
+
+                
+                
+                ## else
+                (wrap (#GenericClass name (list))))))
+      (s;form (do s;Monad
+                [name (s;symbol! ["" "Array"])
+                 component (generic-type^ imports type-vars)]
+                (case component
+                  (^template [ ]
+                    (#GenericClass  #;Nil)
+                    (wrap (#GenericClass  (list))))
+                  (["[Z" "boolean"]
+                   ["[B" "byte"]
+                   ["[S" "short"]
+                   ["[I" "int"]
+                   ["[J" "long"]
+                   ["[F" "float"]
+                   ["[D" "double"]
+                   ["[C" "char"])
+
+                  _
+                  (wrap (#GenericArray component)))))
+      (s;form (do s;Monad
+                [name (full-class-name^ imports)
+                 params (s;some (generic-type^ imports type-vars))
+                 _ (s;assert (not (member? text;Eq (map product;left type-vars) name))
+                             (format name " can't be a type-parameter!"))]
+                (wrap (#GenericClass name params))))
+      ))
+
+(def: (type-param^ imports)
+  (-> ClassImports (Syntax TypeParam))
+  (s;either (do s;Monad
+              [param-name s;local-symbol]
+              (wrap [param-name (list)]))
+            (s;tuple (do s;Monad
+                       [param-name s;local-symbol
+                        _ (s;symbol! ["" "<"])
+                        bounds (s;many (generic-type^ imports (list)))]
+                       (wrap [param-name bounds])))))
+
+(def: (type-params^ imports)
+  (-> ClassImports (Syntax (List TypeParam)))
+  (s;tuple (s;some (type-param^ imports))))
+
+(def: (class-decl^ imports)
+  (-> ClassImports (Syntax ClassDecl))
+  (s;either (do s;Monad
+              [name (full-class-name^ imports)]
+              (wrap [name (list)]))
+            (s;form (do s;Monad
+                      [name (full-class-name^ imports)
+                       params (s;some (type-param^ imports))]
+                      (wrap [name params])))
+            ))
+
+(def: (super-class-decl^ imports type-vars)
+  (-> ClassImports (List TypeParam) (Syntax SuperClassDecl))
+  (s;either (do s;Monad
+              [name (full-class-name^ imports)]
+              (wrap [name (list)]))
+            (s;form (do s;Monad
+                      [name (full-class-name^ imports)
+                       params (s;some (generic-type^ imports type-vars))]
+                      (wrap [name params])))))
+
+(def: annotation-params^
+  (Syntax (List AnnotationParam))
+  (s;record (s;some (s;seq s;local-tag s;any))))
+
+(def: (annotation^ imports)
+  (-> ClassImports (Syntax Annotation))
+  (s;either (do s;Monad
+              [ann-name (full-class-name^ imports)]
+              (wrap [ann-name (list)]))
+            (s;form (s;seq (full-class-name^ imports)
+                           annotation-params^))))
+
+(def: (annotations^' imports)
+  (-> ClassImports (Syntax (List Annotation)))
+  (do s;Monad
+    [_ (s;tag! ["" "ann"])]
+    (s;tuple (s;some (annotation^ imports)))))
+
+(def: (annotations^ imports)
+  (-> ClassImports (Syntax (List Annotation)))
+  (do s;Monad
+    [anns?? (s;opt (annotations^' imports))]
+    (wrap (default (list) anns??))))
+
+(def: (throws-decl'^ imports type-vars)
+  (-> ClassImports (List TypeParam) (Syntax (List GenericType)))
+  (do s;Monad
+    [_ (s;tag! ["" "throws"])]
+    (s;tuple (s;some (generic-type^ imports type-vars)))))
+
+(def: (throws-decl^ imports type-vars)
+  (-> ClassImports (List TypeParam) (Syntax (List GenericType)))
+  (do s;Monad
+    [exs? (s;opt (throws-decl'^ imports type-vars))]
+    (wrap (default (list) exs?))))
+
+(def: (method-decl^ imports type-vars)
+  (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDecl]))
+  (s;form (do s;Monad
+            [tvars (s;default (list) (type-params^ imports))
+             name s;local-symbol
+             anns (annotations^ imports)
+             inputs (s;tuple (s;some (generic-type^ imports type-vars)))
+             output (generic-type^ imports type-vars)
+             exs (throws-decl^ imports type-vars)]
+            (wrap [[name #PublicPM anns] {#method-tvars tvars
+                                          #method-inputs inputs
+                                          #method-output output
+                                          #method-exs    exs}]))))
+
+(def: state-modifier^
+  (Syntax StateModifier)
+  ($_ s;alt
+      (s;tag! ["" "volatile"])
+      (s;tag! ["" "final"])
+      (:: s;Monad wrap [])))
+
+(def: (field-decl^ imports type-vars)
+  (-> ClassImports (List TypeParam) (Syntax [MemberDecl FieldDecl]))
+  (s;either (s;form (do s;Monad
+                      [_ (s;tag! ["" "const"])
+                       name s;local-symbol
+                       anns (annotations^ imports)
+                       type (generic-type^ imports type-vars)
+                       body s;any]
+                      (wrap [[name #PublicPM anns] (#ConstantField [type body])])))
+            (s;form (do s;Monad
+                      [pm privacy-modifier^
+                       sm state-modifier^
+                       name s;local-symbol
+                       anns (annotations^ imports)
+                       type (generic-type^ imports type-vars)]
+                      (wrap [[name pm anns] (#VariableField [sm type])])))))
+
+(def: (arg-decl^ imports type-vars)
+  (-> ClassImports (List TypeParam) (Syntax ArgDecl))
+  (s;record (s;seq s;local-symbol
+                   (generic-type^ imports type-vars))))
+
+(def: (arg-decls^ imports type-vars)
+  (-> ClassImports (List TypeParam) (Syntax (List ArgDecl)))
+  (s;some (arg-decl^ imports type-vars)))
+
+(def: (constructor-arg^ imports type-vars)
+  (-> ClassImports (List TypeParam) (Syntax ConstructorArg))
+  (s;tuple (s;seq (generic-type^ imports type-vars) s;any)))
+
+(def: (constructor-args^ imports type-vars)
+  (-> ClassImports (List TypeParam) (Syntax (List ConstructorArg)))
+  (s;tuple (s;some (constructor-arg^ imports type-vars))))
+
+(def: (constructor-method^ imports class-vars)
+  (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef]))
+  (s;form (do s;Monad
+            [pm privacy-modifier^
+             strict-fp? (s;tag? ["" "strict"])
+             method-vars (s;default (list) (type-params^ imports))
+             #let [total-vars (List/append class-vars method-vars)]
+             [_ arg-decls] (s;form (s;seq (s;symbol! ["" "new"])
+                                          (arg-decls^ imports total-vars)))
+             constructor-args (constructor-args^ imports total-vars)
+             exs (throws-decl^ imports total-vars)
+             annotations (annotations^ imports)
+             body s;any]
+            (wrap [{#member-name constructor-method-name
+                    #member-privacy pm
+                    #member-anns annotations}
+                   (#ConstructorMethod strict-fp? method-vars arg-decls constructor-args body exs)]))))
+
+(def: (virtual-method-def^ imports class-vars)
+  (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef]))
+  (s;form (do s;Monad
+            [pm privacy-modifier^
+             strict-fp? (s;tag? ["" "strict"])
+             final? (s;tag? ["" "final"])
+             method-vars (s;default (list) (type-params^ imports))
+             #let [total-vars (List/append class-vars method-vars)]
+             [name arg-decls] (s;form (s;seq s;local-symbol
+                                             (arg-decls^ imports total-vars)))
+             return-type (generic-type^ imports total-vars)
+             exs (throws-decl^ imports total-vars)
+             annotations (annotations^ imports)
+             body s;any]
+            (wrap [{#member-name name
+                    #member-privacy pm
+                    #member-anns annotations}
+                   (#VirtualMethod final? strict-fp? method-vars arg-decls return-type body exs)]))))
+
+(def: (overriden-method-def^ imports)
+  (-> ClassImports (Syntax [MemberDecl MethodDef]))
+  (s;form (do s;Monad
+            [strict-fp? (s;tag? ["" "strict"])
+             owner-class (class-decl^ imports)
+             method-vars (s;default (list) (type-params^ imports))
+             #let [total-vars (List/append (product;right owner-class) method-vars)]
+             [name arg-decls] (s;form (s;seq s;local-symbol
+                                             (arg-decls^ imports total-vars)))
+             return-type (generic-type^ imports total-vars)
+             exs (throws-decl^ imports total-vars)
+             annotations (annotations^ imports)
+             body s;any]
+            (wrap [{#member-name name
+                    #member-privacy #PublicPM
+                    #member-anns annotations}
+                   (#OverridenMethod strict-fp? owner-class method-vars arg-decls return-type body exs)]))))
+
+(def: (static-method-def^ imports)
+  (-> ClassImports (Syntax [MemberDecl MethodDef]))
+  (s;form (do s;Monad
+            [pm privacy-modifier^
+             strict-fp? (s;tag? ["" "strict"])
+             _ (s;tag! ["" "static"])
+             method-vars (s;default (list) (type-params^ imports))
+             #let [total-vars method-vars]
+             [name arg-decls] (s;form (s;seq s;local-symbol
+                                             (arg-decls^ imports total-vars)))
+             return-type (generic-type^ imports total-vars)
+             exs (throws-decl^ imports total-vars)
+             annotations (annotations^ imports)
+             body s;any]
+            (wrap [{#member-name name
+                    #member-privacy pm
+                    #member-anns annotations}
+                   (#StaticMethod strict-fp? method-vars arg-decls return-type body exs)]))))
+
+(def: (abstract-method-def^ imports)
+  (-> ClassImports (Syntax [MemberDecl MethodDef]))
+  (s;form (do s;Monad
+            [pm privacy-modifier^
+             _ (s;tag! ["" "abstract"])
+             method-vars (s;default (list) (type-params^ imports))
+             #let [total-vars method-vars]
+             [name arg-decls] (s;form (s;seq s;local-symbol
+                                             (arg-decls^ imports total-vars)))
+             return-type (generic-type^ imports total-vars)
+             exs (throws-decl^ imports total-vars)
+             annotations (annotations^ imports)]
+            (wrap [{#member-name name
+                    #member-privacy pm
+                    #member-anns annotations}
+                   (#AbstractMethod method-vars arg-decls return-type exs)]))))
+
+(def: (native-method-def^ imports)
+  (-> ClassImports (Syntax [MemberDecl MethodDef]))
+  (s;form (do s;Monad
+            [pm privacy-modifier^
+             _ (s;tag! ["" "native"])
+             method-vars (s;default (list) (type-params^ imports))
+             #let [total-vars method-vars]
+             [name arg-decls] (s;form (s;seq s;local-symbol
+                                             (arg-decls^ imports total-vars)))
+             return-type (generic-type^ imports total-vars)
+             exs (throws-decl^ imports total-vars)
+             annotations (annotations^ imports)]
+            (wrap [{#member-name name
+                    #member-privacy pm
+                    #member-anns annotations}
+                   (#NativeMethod method-vars arg-decls return-type exs)]))))
+
+(def: (method-def^ imports class-vars)
+  (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef]))
+  ($_ s;either
+      (constructor-method^ imports class-vars)
+      (virtual-method-def^ imports class-vars)
+      (overriden-method-def^ imports)
+      (static-method-def^ imports)
+      (abstract-method-def^ imports)
+      (native-method-def^ imports)))
+
+(def: partial-call^
+  (Syntax PartialCall)
+  (s;form (s;seq s;any s;any)))
+
+(def: class-kind^
+  (Syntax ClassKind)
+  (s;either (do s;Monad
+              [_ (s;tag! ["" "class"])]
+              (wrap #Class))
+            (do s;Monad
+              [_ (s;tag! ["" "interface"])]
+              (wrap #Interface))
+            ))
+
+(def: import-member-alias^
+  (Syntax (Maybe Text))
+  (s;opt (do s;Monad
+           [_ (s;tag! ["" "as"])]
+           s;local-symbol)))
+
+(def: (import-member-args^ imports type-vars)
+  (-> ClassImports (List TypeParam) (Syntax (List [Bool GenericType])))
+  (s;tuple (s;some (s;seq (s;tag? ["" "?"]) (generic-type^ imports type-vars)))))
+
+(def: import-member-return-flags^
+  (Syntax [Bool Bool Bool])
+  ($_ s;seq (s;tag? ["" "io"]) (s;tag? ["" "try"]) (s;tag? ["" "?"])))
+
+(def: primitive-mode^
+  (Syntax Primitive-Mode)
+  (s;alt (s;tag! ["" "manual"])
+         (s;tag! ["" "auto"])))
+
+(def: (import-member-decl^ imports owner-vars)
+  (-> ClassImports (List TypeParam) (Syntax ImportMemberDecl))
+  ($_ s;either
+      (s;form (do s;Monad
+                [_ (s;tag! ["" "enum"])
+                 enum-members (s;some s;local-symbol)]
+                (wrap (#EnumDecl enum-members))))
+      (s;form (do s;Monad
+                [tvars (s;default (list) (type-params^ imports))
+                 _ (s;symbol! ["" "new"])
+                 ?alias import-member-alias^
+                 #let [total-vars (List/append owner-vars tvars)]
+                 ?prim-mode (s;opt primitive-mode^)
+                 args (import-member-args^ imports total-vars)
+                 [io? try? maybe?] import-member-return-flags^]
+                (wrap (#ConstructorDecl [{#import-member-mode    (default #AutoPrM ?prim-mode)
+                                          #import-member-alias   (default "new" ?alias)
+                                          #import-member-kind    #VirtualIMK
+                                          #import-member-tvars   tvars
+                                          #import-member-args    args
+                                          #import-member-maybe?  maybe?
+                                          #import-member-try?    try?
+                                          #import-member-io?     io?}
+                                         {}]))
+                ))
+      (s;form (do s;Monad
+                [kind (: (Syntax ImportMethodKind)
+                         (s;alt (s;tag! ["" "static"])
+                                (wrap [])))
+                 tvars (s;default (list) (type-params^ imports))
+                 name s;local-symbol
+                 ?alias import-member-alias^
+                 #let [total-vars (List/append owner-vars tvars)]
+                 ?prim-mode (s;opt primitive-mode^)
+                 args (import-member-args^ imports total-vars)
+                 [io? try? maybe?] import-member-return-flags^
+                 return (generic-type^ imports total-vars)]
+                (wrap (#MethodDecl [{#import-member-mode    (default #AutoPrM ?prim-mode)
+                                     #import-member-alias   (default name ?alias)
+                                     #import-member-kind    kind
+                                     #import-member-tvars   tvars
+                                     #import-member-args    args
+                                     #import-member-maybe?  maybe?
+                                     #import-member-try?    try?
+                                     #import-member-io?     io?}
+                                    {#import-method-name    name
+                                     #import-method-return  return
+                                     }]))))
+      (s;form (do s;Monad
+                [static? (s;tag? ["" "static"])
+                 name s;local-symbol
+                 ?prim-mode (s;opt primitive-mode^)
+                 gtype (generic-type^ imports owner-vars)
+                 maybe? (s;tag? ["" "?"])
+                 setter? (s;tag? ["" "!"])]
+                (wrap (#FieldAccessDecl {#import-field-mode    (default #AutoPrM ?prim-mode)
+                                         #import-field-name    name
+                                         #import-field-static? static?
+                                         #import-field-maybe?  maybe?
+                                         #import-field-setter? setter?
+                                         #import-field-type    gtype}))))
+      ))
+
+## Generators
+(def: with-parens
+  (-> Code Code)
+  (text;enclose ["(" ")"]))
+
+(def: with-brackets
+  (-> Code Code)
+  (text;enclose ["[" "]"]))
+
+(def: spaced
+  (-> (List Code) Code)
+  (text;join-with " "))
+
+(def: (privacy-modifier$ pm)
+  (-> PrivacyModifier Code)
+  (case pm
+    #PublicPM    "public"
+    #PrivatePM   "private"
+    #ProtectedPM "protected"
+    #DefaultPM   "default"))
+
+(def: (inheritance-modifier$ im)
+  (-> InheritanceModifier Code)
+  (case im
+    #FinalIM    "final"
+    #AbstractIM "abstract"
+    #DefaultIM  "default"))
+
+(def: (annotation-param$ [name value])
+  (-> AnnotationParam Code)
+  (format name "=" (ast;ast-to-text value)))
+
+(def: (annotation$ [name params])
+  (-> Annotation Code)
+  (format "(" name " " "{" (text;join-with "\t" (map annotation-param$ params)) "}" ")"))
+
+(def: (bound-kind$ kind)
+  (-> BoundKind Code)
+  (case kind
+    #UpperBound "<"
+    #LowerBound ">"))
+
+(def: (generic-type$ gtype)
+  (-> GenericType Code)
+  (case gtype
+    (#GenericTypeVar name)
+    name
+
+    (#GenericClass name params)
+    (format "(" name " " (spaced (map generic-type$ params)) ")")
+    
+    (#GenericArray param)
+    (format "(" array-type-name " " (generic-type$ param) ")")
+    
+    (#GenericWildcard #;None)
+    "?"
+
+    (#GenericWildcard (#;Some [bound-kind bound]))
+    (format (bound-kind$ bound-kind) (generic-type$ bound))))
+
+(def: (type-param$ [name bounds])
+  (-> TypeParam Code)
+  (format "(" name " " (spaced (map generic-type$ bounds)) ")"))
+
+(def: (class-decl$ (^open))
+  (-> ClassDecl Code)
+  (format "(" class-name " " (spaced (map type-param$ class-params)) ")"))
+
+(def: (super-class-decl$ (^slots [#super-class-name #super-class-params]))
+  (-> SuperClassDecl Code)
+  (format "(" super-class-name " " (spaced (map generic-type$ super-class-params)) ")"))
+
+(def: (method-decl$ [[name pm anns] method-decl])
+  (-> [MemberDecl MethodDecl] Code)
+  (let [(^slots [#method-tvars #method-inputs #method-output #method-exs]) method-decl]
+    (with-parens
+      (spaced (list name
+                    (with-brackets (spaced (map annotation$ anns)))
+                    (with-brackets (spaced (map type-param$ method-tvars)))
+                    (with-brackets (spaced (map generic-type$ method-exs)))
+                    (with-brackets (spaced (map generic-type$ method-inputs)))
+                    (generic-type$ method-output))
+              ))))
+
+(def: (state-modifier$ sm)
+  (-> StateModifier Code)
+  (case sm
+    #VolatileSM "volatile"
+    #FinalSM    "final"
+    #DefaultSM  "default"))
+
+(def: (field-decl$ [[name pm anns] field])
+  (-> [MemberDecl FieldDecl] Code)
+  (case field
+    (#ConstantField class value)
+    (with-parens
+      (spaced (list "constant" name
+                    (with-brackets (spaced (map annotation$ anns)))
+                    (generic-type$ class)
+                    (ast;ast-to-text value))
+              ))
+
+    (#VariableField sm class)
+    (with-parens
+      (spaced (list "variable" name
+                    (privacy-modifier$ pm)
+                    (state-modifier$ sm)
+                    (with-brackets (spaced (map annotation$ anns)))
+                    (generic-type$ class))
+              ))
+    ))
+
+(def: (arg-decl$ [name type])
+  (-> ArgDecl Code)
+  (with-parens
+    (spaced (list name (generic-type$ type)))))
+
+(def: (constructor-arg$ [class term])
+  (-> ConstructorArg Code)
+  (with-brackets
+    (spaced (list (generic-type$ class) (ast;ast-to-text term)))))
+
+(def: (method-def$ replacer super-class [[name pm anns] method-def])
+  (-> (-> AST AST) SuperClassDecl [MemberDecl MethodDef] Code)
+  (case method-def
+    (#ConstructorMethod strict-fp? type-vars arg-decls constructor-args body exs)
+    (with-parens
+      (spaced (list "init"
+                    (privacy-modifier$ pm)
+                    (Bool/encode strict-fp?)
+                    (with-brackets (spaced (map annotation$ anns)))
+                    (with-brackets (spaced (map type-param$ type-vars)))
+                    (with-brackets (spaced (map generic-type$ exs)))
+                    (with-brackets (spaced (map arg-decl$ arg-decls)))
+                    (with-brackets (spaced (map constructor-arg$ constructor-args)))
+                    (ast;ast-to-text (pre-walk-replace replacer body))
+                    )))
+    
+    (#VirtualMethod final? strict-fp? type-vars arg-decls return-type body exs)
+    (with-parens
+      (spaced (list "virtual"
+                    name
+                    (privacy-modifier$ pm)
+                    (Bool/encode final?)
+                    (Bool/encode strict-fp?)
+                    (with-brackets (spaced (map annotation$ anns)))
+                    (with-brackets (spaced (map type-param$ type-vars)))
+                    (with-brackets (spaced (map generic-type$ exs)))
+                    (with-brackets (spaced (map arg-decl$ arg-decls)))
+                    (generic-type$ return-type)
+                    (ast;ast-to-text (pre-walk-replace replacer body)))))
+    
+    (#OverridenMethod strict-fp? class-decl type-vars arg-decls return-type body exs)
+    (let [super-replacer (parser->replacer (s;form (do s;Monad
+                                                     [_ (s;symbol! ["" ".super!"])
+                                                      args (s;tuple (s;exactly (list;size arg-decls) s;any))
+                                                      #let [arg-decls' (: (List Text) (map (. (simple-class$ (list)) product;right)
+                                                                                           arg-decls))]]
+                                                     (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokespecial" ":" (get@ #super-class-name super-class) ":" name ":" (text;join-with "," arg-decls'))))]
+                                                                           [(~' _jvm_this) (~@ args)]))))))]
+      (with-parens
+        (spaced (list "override"
+                      (class-decl$ class-decl)
+                      name
+                      (Bool/encode strict-fp?)
+                      (with-brackets (spaced (map annotation$ anns)))
+                      (with-brackets (spaced (map type-param$ type-vars)))
+                      (with-brackets (spaced (map generic-type$ exs)))
+                      (with-brackets (spaced (map arg-decl$ arg-decls)))
+                      (generic-type$ return-type)
+                      (|> body
+                          (pre-walk-replace replacer)
+                          (pre-walk-replace super-replacer)
+                          (ast;ast-to-text))
+                      ))))
+
+    (#StaticMethod strict-fp? type-vars arg-decls return-type body exs)
+    (with-parens
+      (spaced (list "static"
+                    name
+                    (privacy-modifier$ pm)
+                    (Bool/encode strict-fp?)
+                    (with-brackets (spaced (map annotation$ anns)))
+                    (with-brackets (spaced (map type-param$ type-vars)))
+                    (with-brackets (spaced (map generic-type$ exs)))
+                    (with-brackets (spaced (map arg-decl$ arg-decls)))
+                    (generic-type$ return-type)
+                    (ast;ast-to-text (pre-walk-replace replacer body)))))
+
+    (#AbstractMethod type-vars arg-decls return-type exs)
+    (with-parens
+      (spaced (list "abstract"
+                    name
+                    (privacy-modifier$ pm)
+                    (with-brackets (spaced (map annotation$ anns)))
+                    (with-brackets (spaced (map type-param$ type-vars)))
+                    (with-brackets (spaced (map generic-type$ exs)))
+                    (with-brackets (spaced (map arg-decl$ arg-decls)))
+                    (generic-type$ return-type))))
+
+    (#NativeMethod type-vars arg-decls return-type exs)
+    (with-parens
+      (spaced (list "native"
+                    name
+                    (privacy-modifier$ pm)
+                    (with-brackets (spaced (map annotation$ anns)))
+                    (with-brackets (spaced (map type-param$ type-vars)))
+                    (with-brackets (spaced (map generic-type$ exs)))
+                    (with-brackets (spaced (map arg-decl$ arg-decls)))
+                    (generic-type$ return-type))))
+    ))
+
+(def: (complete-call$ obj [method args])
+  (-> AST PartialCall AST)
+  (` ((~ method) (~ args) (~ obj))))
+
+## [Syntax]
+(def: object-super-class
+  SuperClassDecl
+  {#super-class-name   "java.lang.Object"
+   #super-class-params (list)})
+
+(syntax: #export (class: {#let [imports (class-imports *compiler*)]}
+                   {im inheritance-modifier^}
+                   {class-decl (class-decl^ imports)}
+                   {#let [full-class-name (product;left class-decl)
+                          imports (add-import [(short-class-name full-class-name) full-class-name]
+                                              (class-imports *compiler*))]}
+                   {#let [class-vars (product;right class-decl)]}
+                   {super (s;opt (super-class-decl^ imports class-vars))}
+                   {interfaces (s;tuple (s;some (super-class-decl^ imports class-vars)))}
+                   {annotations (annotations^ imports)}
+                   {fields (s;some (field-decl^ imports class-vars))}
+                   {methods (s;some (method-def^ imports class-vars))})
+  {#;doc (doc "Allows defining JVM classes in Lux code."
+              "For example:"
+              (class: #final (JvmPromise A) []
+                ## Fields
+                (#private resolved boolean)
+                (#private datum A)
+                (#private waitingList (java.util.List lux.Function))
+                ## Methods
+                (#public new [] [] []
+                         (exec (:= .resolved false)
+                           (:= .waitingList (ArrayList.new []))
+                           []))
+                (#public resolve [] [{value A}] boolean
+                         (let [container (.new! [])]
+                           (synchronized _jvm_this
+                             (if .resolved
+                               false
+                               (exec (:= .datum value)
+                                 (:= .resolved true)
+                                 (let [sleepers .waitingList
+                                       sleepers-count (java.util.List.size [] sleepers)]
+                                   (map (lambda [idx]
+                                          (let [sleeper (java.util.List.get [(l2i idx)] sleepers)]
+                                            (Executor.execute [(@runnable (lux.Function.apply [(:! Object value)] sleeper))]
+                                                              executor)))
+                                        (range 0 (dec (i2l sleepers-count)))))
+                                 (:= .waitingList (null))
+                                 true)))))
+                (#public poll [] [] A
+                         .datum)
+                (#public wasResolved [] [] boolean
+                         (synchronized _jvm_this
+                           .resolved))
+                (#public waitOn [] [{callback lux.Function}] void
+                         (synchronized _jvm_this
+                           (exec (if .resolved
+                                   (lux.Function.apply [(:! Object .datum)] callback)
+                                   (:! Object (java.util.List.add [callback] .waitingList)))
+                             [])))
+                (#public #static make [A] [{value A}] (lux.concurrency.promise.JvmPromise A)
+                         (let [container (.new! [])]
+                           (exec (.resolve! (:! (host lux.concurrency.promise.JvmPromise [Unit]) container) [(:! Unit value)])
+                             container))))
+
+              "The vector corresponds to parent interfaces."
+              "An optional super-class can be specified before the vector. If not specified, java.lang.Object will be assumed."
+              "Fields and methods defined in the class can be used with special syntax."
+              "For example:"
+              ".resolved, for accessing the \"resolved\" field."
+              "(:= .resolved true) for modifying it."
+              "(.new! []) for calling the class's constructor."
+              "(.resolve! container [value]) for calling the \"resolve\" method."
+              )}
+  (do Monad
+    [current-module compiler;current-module-name
+     #let [fully-qualified-class-name (format (text;replace "/" "." current-module) "." full-class-name)
+           field-parsers (map (field->parser fully-qualified-class-name) fields)
+           method-parsers (map (method->parser (product;right class-decl) fully-qualified-class-name) methods)
+           replacer (parser->replacer (fold s;either
+                                            (s;fail "")
+                                            (List/append field-parsers method-parsers)))
+           super-class (default object-super-class super)
+           def-code (format "class:"
+                            (spaced (list (class-decl$ class-decl)
+                                          (super-class-decl$ super-class)
+                                          (with-brackets (spaced (map super-class-decl$ interfaces)))
+                                          (inheritance-modifier$ im)
+                                          (with-brackets (spaced (map annotation$ annotations)))
+                                          (with-brackets (spaced (map field-decl$ fields)))
+                                          (with-brackets (spaced (map (method-def$ replacer super-class) methods))))))]]
+    (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] []))))))
+
+(syntax: #export (interface: {#let [imports (class-imports *compiler*)]}
+                   {class-decl (class-decl^ imports)}
+                   {#let [full-class-name (product;left class-decl)
+                          imports (add-import [(short-class-name full-class-name) full-class-name]
+                                              (class-imports *compiler*))]}
+                   {#let [class-vars (product;right class-decl)]}
+                   {supers (s;tuple (s;some (super-class-decl^ imports class-vars)))}
+                   {annotations (annotations^ imports)}
+                   {members (s;some (method-decl^ imports class-vars))})
+  (let [def-code (format "interface:"
+                         (spaced (list (class-decl$ class-decl)
+                                       (with-brackets (spaced (map super-class-decl$ supers)))
+                                       (with-brackets (spaced (map annotation$ annotations)))
+                                       (spaced (map method-decl$ members)))))]
+    (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] []))))
+    ))
+
+(syntax: #export (object {#let [imports (class-imports *compiler*)]}
+                   {#let [class-vars (list)]}
+                   {super (s;opt (super-class-decl^ imports class-vars))}
+                   {interfaces (s;tuple (s;some (super-class-decl^ imports class-vars)))}
+                   {constructor-args (constructor-args^ imports class-vars)}
+                   {methods (s;some (overriden-method-def^ imports))})
+  {#;doc (doc "Allows defining anonymous classes."
+              "The 1st vector corresponds to parent interfaces."
+              "The 2nd vector corresponds to arguments to the super class constructor."
+              "An optional super-class can be specified before the 1st vector. If not specified, java.lang.Object will be assumed."
+              (object [java.lang.Runnable]
+                []
+                (java.lang.Runnable run [] [] void
+                                    (exec (do-something some-input)
+                                      [])))
+              )}
+  (let [super-class (default object-super-class super)
+        def-code (format "anon-class:"
+                         (spaced (list (super-class-decl$ super-class)
+                                       (with-brackets (spaced (map super-class-decl$ interfaces)))
+                                       (with-brackets (spaced (map constructor-arg$ constructor-args)))
+                                       (with-brackets (spaced (map (method-def$ id super-class) methods))))))]
+    (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] []))))))
+
+(syntax: #export (null)
+  {#;doc (doc "Null object pointer."
+              (null))}
+  (wrap (list (` (;_lux_proc ["jvm" "null"] [])))))
+
+(def: #export (null? obj)
+  {#;doc (doc "Test for null object pointer."
+              (null? (null))
+              "=>"
+              true
+              (null? "YOLO")
+              "=>"
+              false)}
+  (-> (host java.lang.Object) Bool)
+  (;_lux_proc ["jvm" "null?"] [obj]))
+
+(syntax: #export (??? expr)
+  {#;doc (doc "Takes a (potentially null) object pointer and creates a (Maybe ObjectType) for it."
+              (??? (: java.lang.Thread (null)))
+              "=>"
+              #;None
+              (??? "YOLO")
+              "=>"
+              (#;Some "YOLO"))}
+  (with-gensyms [g!temp]
+    (wrap (list (` (let [(~ g!temp) (~ expr)]
+                     (if (;_lux_proc ["jvm" "null?"] [(~ g!temp)])
+                       #;None
+                       (#;Some (~ g!temp)))))))))
+
+(syntax: #export (!!! expr)
+  {#;doc (doc "Takes a (Maybe ObjectType) and return a ObjectType."
+              "A #;None would gets translated in to a (null)."
+              "Takes a (potentially null) object pointer and creates a (Maybe ObjectType) for it."
+              (!!! (??? (: java.lang.Thread (null))))
+              "=>"
+              (null)
+              (!!! (??? "YOLO"))
+              "=>"
+              "YOLO")}
+  (with-gensyms [g!value]
+    (wrap (list (` (;_lux_case (~ expr)
+                     (#;Some (~ g!value))
+                     (~ g!value)
+
+                     #;None
+                     (;_lux_proc ["jvm" "null"] [])))))))
+
+(syntax: #export (try expr)
+  {#;doc (doc "Covers the expression in a try-catch block."
+              "If it succeeds, you get (#;Right result)."
+              "If it fails, you get (#;Left error+stack-traces-as-text)."
+              (try (risky-computation input)))}
+  (wrap (list (`' (_lux_proc ["jvm" "try"]
+                             [(#;Right (~ expr))
+                              ;;throwable->text])))))
+
+(syntax: #export (instance? {#let [imports (class-imports *compiler*)]}
+                            {class (generic-type^ imports (list))}
+                            obj)
+  {#;doc (doc "Checks whether an object is an instance of a particular class."
+              "Caveat emptor: Can't check for polymorphism, so avoid using parameterized classes."
+              (instance? String "YOLO"))}
+  (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ obj)])))))
+
+(syntax: #export (synchronized lock body)
+  {#;doc (doc "Evaluates body, while holding a lock on a given object."
+              (synchronized object-to-be-locked
+                (exec (do-something ...)
+                  (do-something-else ...)
+                  (finish-the-computation ...))))}
+  (wrap (list (` (;_lux_proc ["jvm" "synchronized"] [(~ lock) (~ body)]))))
+  ## (with-gensyms [g!lock g!body g!_ g!e]
+  ##   (wrap (list (` (let [(~ g!lock) (~ lock)
+  ##                        (~ g!_) (;_lux_proc ["jvm" "monitorenter"] [(~ g!lock)])
+  ##                        (~ g!body) (~ body)
+  ##                        (~ g!_) (;_lux_proc ["jvm" "monitorexit"] [(~ g!lock)])]
+  ##                    (~ g!body)))))
+  ##   )
+  )
+
+(syntax: #export (do-to obj {methods (s;some partial-call^)})
+  {#;doc (doc "Call a variety of methods on an object; then return the object."
+              (do-to vreq
+                (HttpServerRequest.setExpectMultipart [true])
+                (ReadStream.handler [(object [(Handler Buffer)]
+                                       []
+                                       ((Handler A) handle [] [(buffer A)] void
+                                        (io;run (do Monad
+                                                  [_ (write (Buffer.getBytes [] buffer) body)]
+                                                  (wrap []))))
+                                       )])
+                (ReadStream.endHandler [[(object [(Handler Void)]
+                                           []
+                                           ((Handler A) handle [] [(_ A)] void
+                                            (exec (do Monad
+                                                    [#let [_ (io;run (close body))]
+                                                     response (handler (request$ vreq body))]
+                                                    (respond! response vreq))
+                                              []))
+                                           )]])))}
+  (with-gensyms [g!obj]
+    (wrap (list (` (let [(~ g!obj) (~ obj)]
+                     (exec (~@ (map (complete-call$ g!obj) methods))
+                       (~ g!obj))))))))
+
+(def: (class-import$ long-name? [full-name params])
+  (-> Bool ClassDecl AST)
+  (let [def-name (if long-name?
+                   full-name
+                   (short-class-name full-name))]
+    (case params
+      #;Nil
+      (` (def: (~ (ast;symbol ["" def-name]))
+           {#;type? true
+            #;;jvm-class (~ (ast;text full-name))}
+           Type
+           (host (~ (ast;symbol ["" full-name])))))
+
+      (#;Cons _)
+      (let [params' (map (lambda [[p _]] (ast;symbol ["" p])) params)]
+        (` (def: (~ (ast;symbol ["" def-name]))
+             {#;type?      true
+              #;;jvm-class (~ (ast;text full-name))}
+             Type
+             (All [(~@ params')]
+               (host (~ (ast;symbol ["" full-name]))
+                     [(~@ params')]))))))))
+
+(def: (member-type-vars class-tvars member)
+  (-> (List TypeParam) ImportMemberDecl (List TypeParam))
+  (case member
+    (#ConstructorDecl [commons _])
+    (List/append class-tvars (get@ #import-member-tvars commons))
+
+    (#MethodDecl [commons _])
+    (case (get@ #import-member-kind commons)
+      #StaticIMK
+      (get@ #import-member-tvars commons)
+
+      _
+      (List/append class-tvars (get@ #import-member-tvars commons)))
+
+    _
+    class-tvars))
+
+(def: (member-def-arg-bindings type-params class member)
+  (-> (List TypeParam) ClassDecl ImportMemberDecl (Lux [(List AST) (List AST) (List Text) (List AST)]))
+  (case member
+    (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
+    (let [(^slots [#import-member-tvars #import-member-args]) commons]
+      (do Monad
+        [arg-inputs (mapM @
+                          (: (-> [Bool GenericType] (Lux [AST AST]))
+                             (lambda [[maybe? _]]
+                               (with-gensyms [arg-name]
+                                 (wrap [arg-name (if maybe?
+                                                   (` (!!! (~ arg-name)))
+                                                   arg-name)]))))
+                          import-member-args)
+         #let [arg-classes (: (List Text)
+                              (map (. (simple-class$ (List/append type-params import-member-tvars)) product;right)
+                                   import-member-args))
+               arg-types (map (: (-> [Bool GenericType] AST)
+                                 (lambda [[maybe? arg]]
+                                   (let [arg-type (class->type (get@ #import-member-mode commons) type-params arg)]
+                                     (if maybe?
+                                       (` (Maybe (~ arg-type)))
+                                       arg-type))))
+                              import-member-args)
+               arg-lambda-inputs (map product;left arg-inputs)
+               arg-method-inputs (map product;right arg-inputs)]]
+        (wrap [arg-lambda-inputs arg-method-inputs arg-classes arg-types])))
+
+    _
+    (:: Monad wrap [(list) (list) (list) (list)])))
+
+(def: (member-def-return mode type-params class member)
+  (-> Primitive-Mode (List TypeParam) ClassDecl ImportMemberDecl (Lux AST))
+  (case member
+    (#ConstructorDecl _)
+    (:: Monad wrap (class-decl-type$ class))
+
+    (#MethodDecl [_ method])
+    (:: Monad wrap (class->type mode type-params (get@ #import-method-return method)))
+
+    _
+    (compiler;fail "Only methods have return values.")))
+
+(def: (decorate-return-maybe member [return-type return-term])
+  (-> ImportMemberDecl [AST AST] [AST AST])
+  (case member
+    (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
+    (if (get@ #import-member-maybe? commons)
+      [(` (Maybe (~ return-type)))
+       (` (??? (~ return-term)))]
+      [return-type
+       (let [g!temp (ast;symbol ["" "Ω"])]
+         (` (let [(~ g!temp) (~ return-term)]
+              (if (null? (:! (host (~' java.lang.Object))
+                             (~ g!temp)))
+                (error! "Can't produce null pointers from method calls.")
+                (~ g!temp)))))])
+
+    _
+    [return-type return-term]))
+
+(do-template [   ]
+  [(def: ( member [return-type return-term])
+     (-> ImportMemberDecl [AST AST] [AST AST])
+     (case member
+       (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
+       (if (get@  commons)
+         [ ]
+         [return-type return-term])
+
+       _
+       [return-type return-term]))]
+
+  [decorate-return-try #import-member-try? (` (Either Text (~ return-type))) (` (try (~ return-term)))]
+  [decorate-return-io  #import-member-io?  (` (IO (~ return-type)))          (` (io (~ return-term)))]
+  )
+
+(def: (free-type-param? [name bounds])
+  (-> TypeParam Bool)
+  (case bounds
+    #;Nil true
+    _     false))
+
+(def: (type-param->type-arg [name _])
+  (-> TypeParam AST)
+  (ast;symbol ["" name]))
+
+(def: (with-mode-output mode output-type body)
+  (-> Primitive-Mode GenericType AST AST)
+  (case mode
+    #ManualPrM
+    body
+    
+    #AutoPrM
+    (case output-type
+      (#GenericClass ["byte" _])
+      (` (b2l (~ body)))
+      
+      (#GenericClass ["short" _])
+      (` (s2l (~ body)))
+      
+      (#GenericClass ["int" _])
+      (` (i2l (~ body)))
+      
+      (#GenericClass ["float" _])
+      (` (f2d (~ body)))
+      
+      _
+      body)))
+
+(def: (auto-conv-class? class)
+  (-> Text Bool)
+  (case class
+    (^or "byte" "short" "int" "float")
+    true
+
+    _
+    false))
+
+(def: (auto-conv [class var])
+  (-> [Text AST] (List AST))
+  (case class
+    "byte"  (list var (` (l2b (~ var))))
+    "short" (list var (` (l2s (~ var))))
+    "int"   (list var (` (l2i (~ var))))
+    "float" (list var (` (d2f (~ var))))
+    _       (list)))
+
+(def: (with-mode-inputs mode inputs body)
+  (-> Primitive-Mode (List [Text AST]) AST AST)
+  (case mode
+    #ManualPrM
+    body
+    
+    #AutoPrM
+    (` (let [(~@ (|> inputs
+                     (List/map auto-conv)
+                     List/join))]
+         (~ body)))))
+
+(def: (with-mode-field-get mode class output)
+  (-> Primitive-Mode GenericType AST AST)
+  (case mode
+    #ManualPrM
+    output
+    
+    #AutoPrM
+    (case (simple-class$ (list) class)
+      "byte"  (` (b2l (~ output)))
+      "short" (` (s2l (~ output)))
+      "int"   (` (i2l (~ output)))
+      "float" (` (f2d (~ output)))
+      _       output)))
+
+(def: (with-mode-field-set mode class input)
+  (-> Primitive-Mode GenericType AST AST)
+  (case mode
+    #ManualPrM
+    input
+    
+    #AutoPrM
+    (case (simple-class$ (list) class)
+      "byte"  (` (l2b (~ input)))
+      "short" (` (l2s (~ input)))
+      "int"   (` (l2i (~ input)))
+      "float" (` (d2f (~ input)))
+      _       input)))
+
+(def: (member-def-interop type-params kind class [arg-lambda-inputs arg-method-inputs arg-classes arg-types] member method-prefix)
+  (-> (List TypeParam) ClassKind ClassDecl [(List AST) (List AST) (List Text) (List AST)] ImportMemberDecl Text (Lux (List AST)))
+  (let [[full-name class-tvars] class
+        all-params (|> (member-type-vars class-tvars member)
+                       (filter free-type-param?)
+                       (map type-param->type-arg))]
+    (case member
+      (#EnumDecl enum-members)
+      (do Monad
+        [#let [enum-type (: AST
+                            (case class-tvars
+                              #;Nil
+                              (` (host (~ (ast;symbol ["" full-name]))))
+
+                              _
+                              (let [=class-tvars (|> class-tvars
+                                                     (filter free-type-param?)
+                                                     (map type-param->type-arg))]
+                                (` (All [(~@ =class-tvars)] (host (~ (ast;symbol ["" full-name])) [(~@ =class-tvars)]))))))
+               getter-interop (: (-> Text AST)
+                                 (lambda [name]
+                                   (let [getter-name (ast;symbol ["" (format method-prefix member-separator name)])]
+                                     (` (def: (~ getter-name)
+                                          (~ enum-type)
+                                          (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" name)))] []))))))]]
+        (wrap (map getter-interop enum-members)))
+      
+      (#ConstructorDecl [commons _])
+      (do Monad
+        [return-type (member-def-return (get@ #import-member-mode commons) type-params class member)
+         #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))])
+               def-params (list (ast;tuple arg-lambda-inputs))
+               jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" full-name ":" (text;join-with "," arg-classes))))]
+                                              [(~@ arg-method-inputs)]))
+                               (with-mode-inputs (get@ #import-member-mode commons)
+                                 (list;zip2 arg-classes arg-lambda-inputs)))
+               [return-type jvm-interop] (|> [return-type jvm-interop]
+                                             (decorate-return-maybe member)
+                                             (decorate-return-try member)
+                                             (decorate-return-io member))]]
+        (wrap (list (` (def: ((~ def-name) (~@ def-params))
+                         (All [(~@ all-params)] (-> [(~@ arg-types)] (~ return-type)))
+                         (~ jvm-interop))))))
+
+      (#MethodDecl [commons method])
+      (with-gensyms [g!obj]
+        (do @
+          [return-type (member-def-return (get@ #import-member-mode commons) type-params class member)
+           #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))])
+                 (^slots [#import-member-kind]) commons
+                 (^slots [#import-method-name]) method
+                 [jvm-op obj-ast class-ast] (: [Text (List AST) (List AST)]
+                                               (case import-member-kind
+                                                 #StaticIMK
+                                                 ["invokestatic"
+                                                  (list)
+                                                  (list)]
+
+                                                 #VirtualIMK
+                                                 (case kind
+                                                   #Class
+                                                   ["invokevirtual"
+                                                    (list g!obj)
+                                                    (list (class-decl-type$ class))]
+                                                   
+                                                   #Interface
+                                                   ["invokeinterface"
+                                                    (list g!obj)
+                                                    (list (class-decl-type$ class))]
+                                                   )))
+                 def-params (#;Cons (ast;tuple arg-lambda-inputs) obj-ast)
+                 def-param-types (#;Cons (` [(~@ arg-types)]) class-ast)
+                 jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format jvm-op ":" full-name ":" import-method-name
+                                                                            ":" (text;join-with "," arg-classes))))]
+                                                [(~@ obj-ast) (~@ arg-method-inputs)]))
+                                 (with-mode-output (get@ #import-member-mode commons)
+                                   (get@ #import-method-return method))
+                                 (with-mode-inputs (get@ #import-member-mode commons)
+                                   (list;zip2 arg-classes arg-lambda-inputs)))
+                 [return-type jvm-interop] (|> [return-type jvm-interop]
+                                               (decorate-return-maybe member)
+                                               (decorate-return-try member)
+                                               (decorate-return-io member))]]
+          (wrap (list (` (def: ((~ def-name) (~@ def-params))
+                           (All [(~@ all-params)] (-> (~@ def-param-types) (~ return-type)))
+                           (~ jvm-interop)))))))
+
+      (#FieldAccessDecl fad)
+      (do Monad
+        [#let [(^open) fad
+               base-gtype (class->type import-field-mode type-params import-field-type)
+               g!class (class-decl-type$ class)
+               g!type (if import-field-maybe?
+                        (` (Maybe (~ base-gtype)))
+                        base-gtype)
+               tvar-asts (: (List AST)
+                            (|> class-tvars
+                                (filter free-type-param?)
+                                (map type-param->type-arg)))
+               getter-name (ast;symbol ["" (format method-prefix member-separator import-field-name)])
+               setter-name (ast;symbol ["" (format method-prefix member-separator import-field-name "!")])]
+         getter-interop (with-gensyms [g!obj]
+                          (let [getter-call (if import-field-static?
+                                              getter-name
+                                              (` ((~ getter-name) (~ g!obj))))
+                                getter-type (if import-field-setter?
+                                              (` (IO (~ g!type)))
+                                              g!type)
+                                getter-type (if import-field-static?
+                                              getter-type
+                                              (` (-> (~ g!class) (~ getter-type))))
+                                getter-type (` (All [(~@ tvar-asts)] (~ getter-type)))
+                                getter-body (if import-field-static?
+                                              (with-mode-field-get import-field-mode import-field-type
+                                                (` (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" import-field-name)))] [])))
+                                              (with-mode-field-get import-field-mode import-field-type
+                                                (` (;_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" full-name ":" import-field-name)))] [(~ g!obj)]))))
+                                getter-body (if import-field-maybe?
+                                              (` (??? (~ getter-body)))
+                                              getter-body)
+                                getter-body (if import-field-setter?
+                                              (` (io (~ getter-body)))
+                                              getter-body)]
+                            (wrap (` (def: (~ getter-call)
+                                       (~ getter-type)
+                                       (~ getter-body))))))
+         setter-interop (if import-field-setter?
+                          (with-gensyms [g!obj g!value]
+                            (let [setter-call (if import-field-static?
+                                                (` ((~ setter-name) (~ g!value)))
+                                                (` ((~ setter-name) (~ g!value) (~ g!obj))))
+                                  setter-type (if import-field-static?
+                                                (` (All [(~@ tvar-asts)] (-> (~ g!type) (IO Unit))))
+                                                (` (All [(~@ tvar-asts)] (-> (~ g!type) (~ g!class) (IO Unit)))))
+                                  setter-value (with-mode-field-set import-field-mode import-field-type g!value)
+                                  setter-value (if import-field-maybe?
+                                                 (` (!!! (~ setter-value)))
+                                                 setter-value)
+                                  setter-command (format (if import-field-static? "putstatic" "putfield")
+                                                         ":" full-name ":" import-field-name)]
+                              (wrap (: (List AST)
+                                       (list (` (def: (~ setter-call)
+                                                  (~ setter-type)
+                                                  (io (;_lux_proc ["jvm" (~ (ast;text setter-command))]
+                                                                  [(~ setter-value)])))))))))
+                          (wrap (list)))]
+        (wrap (list& getter-interop setter-interop)))
+      )))
+
+(def: (member-import$ type-params long-name? kind class member)
+  (-> (List TypeParam) Bool ClassKind ClassDecl ImportMemberDecl (Lux (List AST)))
+  (let [[full-name _] class
+        method-prefix (if long-name?
+                        full-name
+                        (short-class-name full-name))]
+    (do Monad
+      [=args (member-def-arg-bindings type-params class member)]
+      (member-def-interop type-params kind class =args member method-prefix))))
+
+(def: (interface? class)
+  (All [a] (-> (host java.lang.Class [a]) Bool))
+  (_lux_proc ["jvm" "invokevirtual:java.lang.Class:isInterface:"] [class]))
+
+(def: (load-class class-name)
+  (-> Text (Either Text (host java.lang.Class [(Ex [a] a)])))
+  (try (_lux_proc ["jvm" "invokestatic:java.lang.Class:forName:java.lang.String"] [class-name])))
+
+(def: (class-kind [class-name _])
+  (-> ClassDecl (Lux ClassKind))
+  (case (load-class class-name)
+    (#;Right class)
+    (:: Monad wrap (if (interface? class)
+                          #Interface
+                          #Class))
+
+    (#;Left _)
+    (compiler;fail (format "Unknown class: " class-name))))
+
+(syntax: #export (jvm-import {#let [imports (class-imports *compiler*)]}
+                   {long-name? (s;tag? ["" "long"])}
+                   {class-decl (class-decl^ imports)}
+                   {#let [full-class-name (product;left class-decl)
+                          imports (add-import [(short-class-name full-class-name) full-class-name]
+                                              (class-imports *compiler*))]}
+                   {members (s;some (import-member-decl^ imports (product;right class-decl)))})
+  {#;doc (doc "Allows importing JVM classes, and using them as types."
+              "Their methods, fields and enum options can also be imported."
+              "Also, classes which get imported into a module can also be referred-to with their short names in other macros that require JVM classes."
+              "Examples:"
+              (jvm-import java.lang.Object
+                (new [] [])
+                (equals [] [Object] boolean)
+                (wait [] [int] #io #try void))
+              "Special options can also be given for the return values."
+              "#? means that the values will be returned inside a Maybe type. That way, null becomes #;None."
+              "#try means that the computation might throw an exception, and the return value will be wrapped by the Error type."
+              "#io means the computation has side effects, and will be wrapped by the IO type."
+              "These options must show up in the following order [#io #try #?] (although, each option can be used independently)."
+              (jvm-import java.lang.String
+                (new [] [(Array byte)])
+                (#static valueOf [] [char] String)
+                (#static valueOf #as int-valueOf [] [int] String))
+
+              (jvm-import #long (java.util.List e)
+                (size [] [] int)
+                (get [] [int] e))
+
+              (jvm-import (java.util.ArrayList a)
+                (toArray [T] [(Array T)] (Array T)))
+              "#long makes it so the class-type that is generated is of the fully-qualified name."
+              "In this case, it avoids a clash between the java.util.List type, and Lux's own List type."
+              (jvm-import java.lang.Character$UnicodeScript
+                (#enum ARABIC CYRILLIC LATIN))
+              "All enum options to be imported must be specified."
+
+              (jvm-import #long (lux.concurrency.promise.JvmPromise A)
+                (resolve [] [A] boolean)
+                (poll [] [] A)
+                (wasResolved [] [] boolean)
+                (waitOn [] [lux.Function] void)
+                (#static make [A] [A] (JvmPromise A)))
+              "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-parameters."
+              "Lux types, such as Maybe can't be named (otherwise, they'd be confused for Java classes)."
+              
+              "Also, the names of the imported members will look like ClassName.MemberName."
+              "E.g.:"
+              (Object.new [])
+              (Object.equals [other-object] my-object)
+              (java.util.List.size [] my-list)
+              Character$UnicodeScript.LATIN
+              )}
+  (do Monad
+    [kind (class-kind class-decl)
+     =members (mapM @ (member-import$ (product;right class-decl) long-name? kind class-decl) members)]
+    (wrap (list& (class-import$ long-name? class-decl) (List/join =members)))))
+
+(syntax: #export (array {#let [imports (class-imports *compiler*)]}
+                        {type (generic-type^ imports (list))}
+                        size)
+  {#;doc (doc "Create an array of the given type, with the given size."
+              (array Object +10))}
+  (case type
+    (^template [ ]
+      (^ (#GenericClass  (list)))
+      (wrap (list (` (;_lux_proc ["jvm" ] [(~ size)])))))
+    (["boolean" "znewarray"]
+     ["byte"    "bnewarray"]
+     ["short"   "snewarray"]
+     ["int"     "inewarray"]
+     ["long"    "lnewarray"]
+     ["float"   "fnewarray"]
+     ["double"  "dnewarray"]
+     ["char"    "cnewarray"])
+
+    _
+    (wrap (list (` (;_lux_proc ["jvm" "anewarray"] [(~ (ast;text (generic-type$ type))) (~ size)]))))))
+
+(syntax: #export (array-length array)
+  {#;doc (doc "Gives the length of an array."
+              (array-length my-array))}
+  (wrap (list (` (;_lux_proc ["jvm" "arraylength"] [(~ array)])))))
+
+(def: (type->class-name type)
+  (-> Type (Lux Text))
+  (case type
+    (#;HostT name params)
+    (:: Monad wrap name)
+
+    (#;AppT F A)
+    (case (type;apply-type F A)
+      #;None
+      (compiler;fail (format "Can't apply type: " (type;type-to-text F) " to " (type;type-to-text A)))
+
+      (#;Some type')
+      (type->class-name type'))
+    
+    (#;NamedT _ type')
+    (type->class-name type')
+
+    #;UnitT
+    (:: Monad wrap "java.lang.Object")
+    
+    (^or #;VoidT (#;VarT _) (#;ExT _) (#;BoundT _) (#;SumT _) (#;ProdT _) (#;LambdaT _) (#;UnivQ _) (#;ExQ _))
+    (compiler;fail (format "Can't convert to JvmType: " (type;type-to-text type)))
+    ))
+
+(syntax: #export (array-load idx array)
+  {#;doc (doc "Loads an element from an array."
+              (array-load 10 my-array))}
+  (case array
+    [_ (#;SymbolS array-name)]
+    (do Monad
+      [array-type (compiler;find-type array-name)
+       array-jvm-type (type->class-name array-type)]
+      (case array-jvm-type
+        (^template [ ]
+          
+          (wrap (list (` (;_lux_proc ["jvm" ] [(~ array) (~ idx)])))))
+        (["[Z" "zaload"]
+         ["[B" "baload"]
+         ["[S" "saload"]
+         ["[I" "iaload"]
+         ["[J" "jaload"]
+         ["[F" "faload"]
+         ["[D" "daload"]
+         ["[C" "caload"])
+
+        _
+        (wrap (list (` (;_lux_proc ["jvm" "aaload"] [(~ array) (~ idx)]))))))
+
+    _
+    (with-gensyms [g!array]
+      (wrap (list (` (let [(~ g!array) (~ array)]
+                       (;;array-load (~ g!array) (~ idx)))))))))
+
+(syntax: #export (array-store idx value array)
+  {#;doc (doc "Stores an element into an array."
+              (array-store 10 my-object my-array))}
+  (case array
+    [_ (#;SymbolS array-name)]
+    (do Monad
+      [array-type (compiler;find-type array-name)
+       array-jvm-type (type->class-name array-type)]
+      (case array-jvm-type
+        (^template [ ]
+          
+          (wrap (list (` (;_lux_proc ["jvm" ] [(~ array) (~ idx) (~ value)])))))
+        (["[Z" "zastore"]
+         ["[B" "bastore"]
+         ["[S" "sastore"]
+         ["[I" "iastore"]
+         ["[J" "jastore"]
+         ["[F" "fastore"]
+         ["[D" "dastore"]
+         ["[C" "castore"])
+
+        _
+        (wrap (list (` (;_lux_proc ["jvm" "aastore"] [(~ array) (~ idx) (~ value)]))))))
+
+    _
+    (with-gensyms [g!array]
+      (wrap (list (` (let [(~ g!array) (~ array)]
+                       (;;array-store (~ g!array) (~ idx) (~ value)))))))))
+
+(def: simple-bindings^
+  (Syntax (List [Text AST]))
+  (s;tuple (s;some (s;seq s;local-symbol s;any))))
+
+(syntax: #export (with-open {bindings simple-bindings^} body)
+  {#;doc (doc "Creates a local-binding with the desired resources, and runs the body (assumed to be in the IO type)."
+              "Afterwards, closes all resources (assumed to be subclasses of java.io.Closeable), and returns the value resulting from running the body."
+              (with-open [my-res1 (res1-constructor ...)
+                          my-res2 (res1-constructor ...)]
+                (do Monad
+                  [foo (do-something my-res1)
+                   bar (do-something-else my-res2)]
+                  (do-one-last-thing foo bar))))}
+  (with-gensyms [g!output g!_]
+    (let [inits (List/join (List/map (lambda [[res-name res-ctor]]
+                                       (list (ast;symbol ["" res-name]) res-ctor))
+                                     bindings))
+          closes (List/map (lambda [res]
+                             (` (try (;_lux_proc ["jvm" "invokevirtual:java.io.Closeable:close:"]
+                                                 [(~ (ast;symbol ["" (product;left res)]))]))))
+                           bindings)]
+      (wrap (list (` (do Monad
+                       [(~@ inits)
+                        (~ g!output) (~ body)
+                        (~' #let) [(~ g!_) (exec (~@ (reverse closes)) [])]]
+                       ((~' wrap) (~ g!output)))))))))
+
+(syntax: #export (class-for {#let [imports (class-imports *compiler*)]}
+                            {type (generic-type^ imports (list))})
+  {#;doc (doc "Loads the class a a Class object."
+              (class-for java.lang.String))}
+  (wrap (list (` (;_lux_proc ["jvm" "load-class"] [(~ (ast;text (simple-class$ (list) type)))])))))
diff --git a/stdlib/source/lux/lexer.lux b/stdlib/source/lux/lexer.lux
new file mode 100644
index 000000000..654259d8d
--- /dev/null
+++ b/stdlib/source/lux/lexer.lux
@@ -0,0 +1,439 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  [lux #- not]
+  (lux (control functor
+                applicative
+                monad
+                codec)
+       (data [text "Text/" Eq]
+             text/format
+             [number "Int/" Codec]
+             [product]
+             [char "Char/" Ord]
+             maybe
+             error
+             (struct [list "" Functor]))
+       host))
+
+## [Types]
+(type: #export (Lexer a)
+  (-> Text (Error [Text a])))
+
+## [Structures]
+(struct: #export _ (Functor Lexer)
+  (def: (map f fa)
+    (lambda [input]
+      (case (fa input)
+        (#;Left msg)              (#;Left msg)
+        (#;Right [input' output]) (#;Right [input' (f output)])))))
+
+(struct: #export _ (Applicative Lexer)
+  (def: functor Functor)
+
+  (def: (wrap a)
+    (lambda [input]
+      (#;Right [input a])))
+
+  (def: (apply ff fa)
+    (lambda [input]
+      (case (ff input)
+        (#;Right [input' f])
+        (case (fa input')
+          (#;Right [input'' a])
+          (#;Right [input'' (f a)])
+
+          (#;Left msg)
+          (#;Left msg))
+
+        (#;Left msg)
+        (#;Left msg)))))
+
+(struct: #export _ (Monad Lexer)
+  (def: applicative Applicative)
+  
+  (def: (join mma)
+    (lambda [input]
+      (case (mma input)
+        (#;Left msg)          (#;Left msg)
+        (#;Right [input' ma]) (ma input'))))
+  )
+
+## [Values]
+## Runner
+(def: #export (run' lexer input)
+  (All [a] (-> (Lexer a) Text (Error [Text a])))
+  (lexer input))
+
+(def: #export (run lexer input)
+  (All [a] (-> (Lexer a) Text (Error a)))
+  (case (lexer input)
+    (#;Left msg)
+    (#;Left msg)
+    
+    (#;Right [input' output])
+    (#;Right output)
+    ))
+
+## Combinators
+(def: #export (fail message)
+  (All [a] (-> Text (Lexer a)))
+  (lambda [input]
+    (#;Left message)))
+
+(def: #export any
+  (Lexer Char)
+  (lambda [input]
+    (case [(text;at +0 input) (text;split +1 input)]
+      [(#;Some output) (#;Some [_ input'])]
+      (#;Right [input' output])
+
+      _
+      (#;Left "Can't parse character from empty text."))
+    ))
+
+(def: #export (seq left right)
+  (All [a b] (-> (Lexer a) (Lexer b) (Lexer [a b])))
+  (do Monad
+    [=left left
+     =right right]
+    (wrap [=left =right])))
+
+(def: #export (alt left right)
+  (All [a b] (-> (Lexer a) (Lexer b) (Lexer (| a b))))
+  (lambda [input]
+    (case (left input)
+      (#;Left msg)
+      (case (right input)
+        (#;Left msg)
+        (#;Left msg)
+
+        (#;Right [input' output])
+        (#;Right [input' (+1 output)]))
+
+      (#;Right [input' output])
+      (#;Right [input' (+0 output)]))))
+
+(def: #export (not! p)
+  (All [a] (-> (Lexer a) (Lexer Unit)))
+  (lambda [input]
+    (case (p input)
+      (#;Left msg)
+      (#;Right [input []])
+      
+      _
+      (#;Left "Expected to fail; yet succeeded."))))
+
+(def: #export (not p)
+  (All [a] (-> (Lexer a) (Lexer Char)))
+  (lambda [input]
+    (case (p input)
+      (#;Left msg)
+      (any input)
+      
+      _
+      (#;Left "Expected to fail; yet succeeded."))))
+
+(def: #export (either left right)
+  (All [a] (-> (Lexer a) (Lexer a) (Lexer a)))
+  (lambda [input]
+    (case (left input)
+      (#;Left msg)
+      (right input)
+
+      output
+      output)))
+
+(def: #export (assert test message)
+  (-> Bool Text (Lexer Unit))
+  (lambda [input]
+    (if test
+      (#;Right [input []])
+      (#;Left message))))
+
+(def: #export (some p)
+  (All [a] (-> (Lexer a) (Lexer (List a))))
+  (lambda [input]
+    (case (p input)
+      (#;Left msg)
+      (#;Right [input (list)])
+      
+      (#;Right [input' x])
+      (run' (do Monad
+              [xs (some p)]
+              (wrap (#;Cons x xs)))
+            input'))
+    ))
+
+(def: #export (many p)
+  (All [a] (-> (Lexer a) (Lexer (List a))))
+  (do Monad
+    [x p
+     xs (some p)]
+    (wrap (#;Cons x xs))))
+
+(def: #export (exactly n p)
+  (All [a] (-> Nat (Lexer a) (Lexer (List a))))
+  (if (>+ +0 n)
+    (do Monad
+      [x p
+       xs (exactly (dec+ n) p)]
+      (wrap (#;Cons x xs)))
+    (:: Monad wrap (list))))
+
+(def: #export (at-most n p)
+  (All [a] (-> Nat (Lexer a) (Lexer (List a))))
+  (if (>+ +0 n)
+    (lambda [input]
+      (case (p input)
+        (#;Left msg)
+        (#;Right [input (list)])
+
+        (#;Right [input' x])
+        (run' (do Monad
+                [xs (at-most (dec+ n) p)]
+                (wrap (#;Cons x xs)))
+              input')
+        ))
+    (:: Monad wrap (list))))
+
+(def: #export (at-least n p)
+  (All [a] (-> Nat (Lexer a) (Lexer (List a))))
+  (do Monad
+    [min-xs (exactly n p)
+     extras (some p)]
+    (wrap (list;concat (list min-xs extras)))))
+
+(def: #export (between from to p)
+  (All [a] (-> Nat Nat (Lexer a) (Lexer (List a))))
+  (do Monad
+    [min-xs (exactly from p)
+     max-xs (at-most (-+ from to) p)]
+    (wrap (list;concat (list min-xs max-xs)))))
+
+(def: #export (opt p)
+  (All [a] (-> (Lexer a) (Lexer (Maybe a))))
+  (lambda [input]
+    (case (p input)
+      (#;Left msg)
+      (#;Right [input #;None])
+
+      (#;Right [input value])
+      (#;Right [input (#;Some value)])
+      )))
+
+(def: #export (this text)
+  (-> Text (Lexer Text))
+  (lambda [input]
+    (if (text;starts-with? text input)
+      (case (text;split (text;size text) input)
+        #;None              (#;Left "")
+        (#;Some [_ input']) (#;Right [input' text]))
+      (#;Left (format "Invalid match: " text " @ " (:: text;Codec encode input))))
+    ))
+
+(def: #export (sep-by sep p)
+  (All [a b] (-> (Lexer b) (Lexer a) (Lexer (List a))))
+  (do Monad
+    [?x (opt p)]
+    (case ?x
+      #;None
+      (wrap #;Nil)
+      
+      (#;Some x)
+      (do @
+        [xs' (some (seq sep p))]
+        (wrap (#;Cons x (map product;right xs'))))
+      )))
+
+(def: #export end
+  (Lexer Unit)
+  (lambda [input]
+    (case input
+      "" (#;Right [input []])
+      _  (#;Left (format "The text input has not been fully consumed @ " (:: text;Codec encode input)))
+      )))
+
+(def: #export peek
+  (Lexer Char)
+  (lambda [input]
+    (case (text;at +0 input)
+      (#;Some output)
+      (#;Right [input output])
+
+      _
+      (#;Left "Can't peek character from empty text."))
+    ))
+
+(def: #export (this-char char)
+  (-> Char (Lexer Char))
+  (lambda [input]
+    (case [(text;at +0 input) (text;split +1 input)]
+      [(#;Some char') (#;Some [_ input'])]
+      (if (Char/= char char')
+        (#;Right [input' char])
+        (#;Left (format "Expected " (:: char;Codec encode char) " @ " (:: text;Codec encode input)
+                        " " (Int/encode (c2l char))" " (Int/encode (c2l [char'])))))
+
+      _
+      (#;Left "Can't parse character from empty text."))
+    ))
+
+(def: #export get-input
+  (Lexer Text)
+  (lambda [input]
+    (#;Right [input input])))
+
+(def: #export (char-range bottom top)
+  (-> Char Char (Lexer Char))
+  (do Monad
+    [input get-input
+     char any
+     _ (assert (and (Char/>= bottom char)
+                    (Char/<= top char))
+               (format "Character is not within range: " (:: char;Codec encode bottom) "-" (:: char;Codec encode top) " @ " (:: text;Codec encode input)))]
+    (wrap char)))
+
+(do-template [  ]
+  [(def: #export 
+     (Lexer Char)
+     (char-range  ))]
+
+  [upper     #"A" #"Z"]
+  [lower     #"a" #"z"]
+  [digit     #"0" #"9"]
+  [oct-digit #"0" #"7"]
+  )
+
+(def: #export alpha
+  (Lexer Char)
+  (either lower upper))
+
+(def: #export alpha-num
+  (Lexer Char)
+  (either alpha digit))
+
+(def: #export hex-digit
+  (Lexer Char)
+  ($_ either
+      digit
+      (char-range #"a" #"f")
+      (char-range #"A" #"F")))
+
+(def: #export (one-of options)
+  (-> Text (Lexer Char))
+  (lambda [input]
+    (case (text;split +1 input)
+      (#;Some [init input'])
+      (if (text;contains? init options)
+        (case (text;at +0 init)
+          (#;Some output)
+          (#;Right [input' output])
+
+          _
+          (#;Left ""))
+        (#;Left (format "Character (" init ") is not one of: " options " @ " (:: text;Codec encode input))))
+
+      _
+      (#;Left "Can't parse character from empty text."))))
+
+(def: #export (none-of options)
+  (-> Text (Lexer Char))
+  (lambda [input]
+    (case (text;split +1 input)
+      (#;Some [init input'])
+      (if (;not (text;contains? init options))
+        (case (text;at +0 init)
+          (#;Some output)
+          (#;Right [input' output])
+
+          _
+          (#;Left ""))
+        (#;Left (format "Character (" init ") is one of: " options " @ " (:: text;Codec encode input))))
+
+      _
+      (#;Left "Can't parse character from empty text."))))
+
+(def: #export (satisfies p)
+  (-> (-> Char Bool) (Lexer Char))
+  (lambda [input]
+    (case (: (Maybe [Text Char])
+             (do Monad
+               [[init input'] (text;split +1 input)
+                output (text;at +0 init)]
+               (wrap [input' output])))
+      (#;Some [input' output])
+      (if (p output)
+        (#;Right [input' output])
+        (#;Left (format "Character does not satisfy predicate: " (:: text;Codec encode input))))
+
+      _
+      (#;Left "Can't parse character from empty text."))))
+
+(def: #export space
+  (Lexer Char)
+  (satisfies char;space?))
+
+(def: #export (some' p)
+  (-> (Lexer Char) (Lexer Text))
+  (do Monad
+    [cs (some p)]
+    (wrap (text;concat (map char;as-text cs)))))
+
+(def: #export (many' p)
+  (-> (Lexer Char) (Lexer Text))
+  (do Monad
+    [cs (many p)]
+    (wrap (text;concat (map char;as-text cs)))))
+
+(def: #export end?
+  (Lexer Bool)
+  (lambda [input]
+    (#;Right [input (text;empty? input)])))
+
+(def: #export (_& left right)
+  (All [a b] (-> (Lexer a) (Lexer b) (Lexer b)))
+  (do Monad
+    [_ left]
+    right))
+
+(def: #export (&_ left right)
+  (All [a b] (-> (Lexer a) (Lexer b) (Lexer a)))
+  (do Monad
+    [output left
+     _ right]
+    (wrap output)))
+
+(def: #export (default value lexer)
+  (All [a] (-> a (Lexer a) (Lexer a)))
+  (lambda [input]
+    (case (lexer input)
+      (#;Left error)
+      (#;Right [input value])
+
+      (#;Right input'+value)
+      (#;Right input'+value))))
+
+(def: #export (codec codec lexer)
+  (All [a] (-> (Codec Text a) (Lexer Text) (Lexer a)))
+  (lambda [input]
+    (case (lexer input)
+      (#;Left error)
+      (#;Left error)
+
+      (#;Right [input' to-decode])
+      (case (:: codec decode to-decode)
+        (#;Left error)
+        (#;Left error)
+        
+        (#;Right value)
+        (#;Right [input' value])))))
+
+(def: #export (enclosed [start end] lexer)
+  (All [a] (-> [Text Text] (Lexer a) (Lexer a)))
+  (_& (this start)
+      (&_ lexer
+          (this end))))
diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux
new file mode 100644
index 000000000..7c192cb2b
--- /dev/null
+++ b/stdlib/source/lux/macro.lux
@@ -0,0 +1,31 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monad)
+       (data (struct [list "List/" Monad])
+             text/format)
+       [compiler]
+       (macro ["s" syntax #+ syntax: Syntax])))
+
+(def: omit^
+  (Syntax Bool)
+  (s;tag? ["" "omit"]))
+
+(do-template [ ]
+  [(syntax: #export ( {? omit^} token)
+     (do @
+       [output ( token)
+        #let [_ (List/map (. log! %ast)
+                          output)]]
+       (if ?
+         (wrap (list))
+         (wrap output))))]
+
+  [expand      compiler;macro-expand]
+  [expand-all  compiler;macro-expand-all]
+  [expand-once compiler;macro-expand-once]
+  )
diff --git a/stdlib/source/lux/macro/ast.lux b/stdlib/source/lux/macro/ast.lux
new file mode 100644
index 000000000..cc1cffa5f
--- /dev/null
+++ b/stdlib/source/lux/macro/ast.lux
@@ -0,0 +1,149 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control eq)
+       (data bool
+             number
+             [char]
+             [text #+ Eq "Text/" Monoid]
+             ident
+             (struct [list #* "" Functor Fold])
+             )))
+
+## [Types]
+## (type: (AST' w)
+##   (#;BoolS Bool)
+##   (#;NatS Nat)
+##   (#;IntS Int)
+##   (#;RealS Real)
+##   (#;CharS Char)
+##   (#;TextS Text)
+##   (#;SymbolS Text Text)
+##   (#;TagS Text Text)
+##   (#;FormS (List (w (AST' w))))
+##   (#;TupleS (List (w (AST' w))))
+##   (#;RecordS (List [(w (AST' w)) (w (AST' w))])))
+
+## (type: AST
+##   (Meta Cursor (AST' (Meta Cursor))))
+
+## [Utils]
+(def: _cursor Cursor ["" -1 -1])
+
+## [Functions]
+(do-template [  ]
+  [(def: #export ( x)
+     (->  AST)
+     [_cursor ( x)])]
+  
+  [bool   Bool             #;BoolS]
+  [nat    Nat              #;NatS]
+  [int    Int              #;IntS]
+  [frac   Frac             #;FracS]
+  [real   Real             #;RealS]
+  [char   Char             #;CharS]
+  [text   Text             #;TextS]
+  [symbol Ident            #;SymbolS]
+  [tag    Ident            #;TagS]
+  [form   (List AST)       #;FormS]
+  [tuple  (List AST)       #;TupleS]
+  [record (List [AST AST]) #;RecordS]
+  )
+
+(do-template [ ]
+  [(def: #export ( name)
+     (-> Text AST)
+     [_cursor ( ["" name])])]
+
+  [local-symbol #;SymbolS]
+  [local-tag    #;TagS])
+
+## [Structures]
+(struct: #export _ (Eq AST)
+  (def: (= x y)
+    (case [x y]
+      (^template [ ]
+       [[_ ( x')] [_ ( y')]]
+       (::  = x' y'))
+      ([#;BoolS   Eq]
+       [#;NatS    Eq]
+       [#;IntS    Eq]
+       [#;FracS   Eq]
+       [#;RealS   Eq]
+       [#;CharS   char;Eq]
+       [#;TextS   Eq]
+       [#;SymbolS Eq]
+       [#;TagS    Eq])
+
+      (^template []
+       [[_ ( xs')] [_ ( ys')]]
+       (and (:: Eq = (size xs') (size ys'))
+            (fold (lambda [[x' y'] old]
+                    (and old (= x' y')))
+                  true
+                  (zip2 xs' ys'))))
+      ([#;FormS]
+       [#;TupleS])
+
+      [[_ (#;RecordS xs')] [_ (#;RecordS ys')]]
+      (and (:: Eq = (size xs') (size ys'))
+           (fold (lambda [[[xl' xr'] [yl' yr']] old]
+                   (and old (= xl' yl') (= xr' yr')))
+                 true
+                 (zip2 xs' ys')))
+      
+      _
+      false)))
+
+## [Values]
+(def: #export (ast-to-text ast)
+  (-> AST Text)
+  (case ast
+    (^template [ ]
+     [_ ( value)]
+     (::  encode value))
+    ([#;BoolS   Codec]
+     [#;NatS    Codec]
+     [#;IntS    Codec]
+     [#;FracS   Codec]
+     [#;RealS   Codec]
+     [#;CharS   char;Codec]
+     [#;TextS   text;Codec]
+     [#;SymbolS Codec])
+
+    [_ (#;TagS ident)]
+    (Text/append  "#" (:: Codec encode ident))
+
+    (^template [  ]
+     [_ ( members)]
+     ($_ Text/append  (|> members (map ast-to-text) (interpose " ") (text;join-with "")) ))
+    ([#;FormS  "(" ")"]
+     [#;TupleS "[" "]"])
+
+    [_ (#;RecordS pairs)]
+    ($_ Text/append "{" (|> pairs (map (lambda [[left right]] ($_ Text/append (ast-to-text left) " " (ast-to-text right)))) (interpose " ") (text;join-with "")) "}")
+    ))
+
+(def: #export (replace source target ast)
+  (-> AST AST AST AST)
+  (if (:: Eq = source ast)
+    target
+    (case ast
+      (^template []
+       [cursor ( parts)]
+       [cursor ( (map (replace source target) parts))])
+      ([#;FormS]
+       [#;TupleS])
+
+      [cursor (#;RecordS parts)]
+      [cursor (#;RecordS (map (lambda [[left right]]
+                                [(replace source target left)
+                                 (replace source target right)])
+                              parts))]
+
+      _
+      ast)))
diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux
new file mode 100644
index 000000000..ac7043f26
--- /dev/null
+++ b/stdlib/source/lux/macro/poly.lux
@@ -0,0 +1,364 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  [lux #- list]
+  (lux (control monad
+                [eq])
+       (data [text]
+             text/format
+             (struct [list "List/" Monad]
+                     [dict #+ Dict])
+             [number]
+             [product]
+             [bool]
+             [char]
+             [maybe])
+       [compiler #+ Monad with-gensyms]
+       (macro [ast]
+              ["s" syntax #+ syntax: Syntax]
+              (syntax [common]))
+       [type]
+       ))
+
+## [Types]
+(type: #export (Matcher a)
+  (-> Type (Lux a)))
+
+(type: #export Env (Dict Nat AST))
+
+## [Combinators]
+(do-template [ ]
+  [(def: #export 
+     (Matcher Unit)
+     (lambda [:type:]
+       (case (type;un-alias :type:)
+         (#;NamedT ["lux" ] _)
+         (:: compiler;Monad wrap [])
+
+         _
+         (compiler;fail (format "Not "  " type: " (type;type-to-text :type:))))))]
+
+  [unit "Unit"]
+  [bool "Bool"]
+  [nat  "Nat"]
+  [int  "Int"]
+  [frac "Frac"]
+  [real "Real"]
+  [char "Char"]
+  [text "Text"]
+  )
+
+(def: #export primitive
+  (Matcher Type)
+  (lambda [:type:]
+    (let% [ (do-template [ ]
+                          [(do Monad
+                             [_ ( :type:)]
+                             (wrap ))]
+
+                          [bool Bool]
+                          [nat  Nat]
+                          [int  Int]
+                          [frac Frac]
+                          [real Real]
+                          [char Char]
+                          [text Text])]
+      ($_ compiler;either
+          ))))
+
+(syntax: ($AST$ ast)
+  (wrap (;list (ast;text (ast;ast-to-text ast)))))
+
+(do-template [   ]
+  [(def: #export 
+     (Matcher [Type Type])
+     (lambda [:type:]
+       (case (type;un-name :type:)
+         ( :left: :right:)
+         (:: compiler;Monad wrap [:left: :right:])
+
+         _
+         (compiler;fail (format "Not a " ($AST$ ) " type: " (type;type-to-text :type:))))))
+
+   (def: #export 
+     (Matcher (List Type))
+     (lambda [:type:]
+       (let [members ( (type;un-name :type:))]
+         (if (>+ +1 (list;size members))
+           (:: compiler;Monad wrap members)
+           (compiler;fail (format "Not a " ($AST$ ) " type: " (type;type-to-text :type:)))))))]
+
+  [sum    sum+    type;flatten-sum      #;SumT]
+  [prod   prod+   type;flatten-prod     #;ProdT]
+  )
+
+(def: #export func
+  (Matcher [Type Type])
+  (lambda [:type:]
+    (case (type;un-name :type:)
+      (#;LambdaT :left: :right:)
+      (:: compiler;Monad wrap [:left: :right:])
+
+      _
+      (compiler;fail (format "Not a LambdaT type: " (type;type-to-text :type:))))))
+
+(def: #export func+
+  (Matcher [(List Type) Type])
+  (lambda [:type:]
+    (let [[ins out] (type;flatten-function (type;un-name :type:))]
+      (if (>+ +0 (list;size ins))
+        (:: compiler;Monad wrap [ins out])
+        (compiler;fail (format "Not a LambdaT type: " (type;type-to-text :type:)))))))
+
+(def: #export tagged
+  (Matcher [(List Ident) Type])
+  (lambda [:type:]
+    (case (type;un-alias :type:)
+      (#;NamedT type-name :def:)
+      (do compiler;Monad
+        [tags (compiler;tags-of type-name)]
+        (wrap [tags :def:]))
+
+      _
+      (compiler;fail (format "Unnamed types can't have tags: " (type;type-to-text :type:))))))
+
+(def: #export polymorphic
+  (Matcher [(List AST) Type])
+  (lambda [:type:]
+    (loop [:type: (type;un-name :type:)]
+      (case :type:
+        (#;UnivQ _ :type:')
+        (do compiler;Monad
+          [[g!tail :type:''] (recur :type:')
+           g!head (compiler;gensym "type-var")]
+          (wrap [(list& g!head g!tail)
+                 :type:'']))
+
+        _
+        (:: compiler;Monad wrap [(;list) :type:])))))
+
+(do-template [ ]
+  [(def: #export 
+     (Matcher [(List AST) (List [Ident Type])])
+     (lambda [:type:]
+       (do compiler;Monad
+         [[tags :type:] (tagged :type:)
+          _ (compiler;assert (>+ +0 (list;size tags)) "Records and variants must have tags.")
+          [vars :type:] (polymorphic :type:)
+          members ( :type:)]
+         (wrap [vars (list;zip2 tags members)]))))]
+
+  [variant sum+]
+  [record  prod+]
+  )
+
+(def: #export tuple
+  (Matcher [(List AST) (List Type)])
+  (lambda [:type:]
+    (do compiler;Monad
+      [[vars :type:] (polymorphic :type:)
+       members (prod+ :type:)]
+      (wrap [vars members]))))
+
+(def: #export function
+  (Matcher [(List AST) [(List Type) Type]])
+  (lambda [:type:]
+    (do compiler;Monad
+      [[vars :type:] (polymorphic :type:)
+       ins+out (func+ :type:)]
+      (wrap [vars ins+out]))))
+
+(def: #export apply
+  (Matcher [Type (List Type)])
+  (lambda [:type:]
+    (do compiler;Monad
+      [#let [[:func: :args:] (loop [:type: (type;un-name :type:)]
+                               (case :type:
+                                 (#;AppT :func: :arg:)
+                                 (let [[:func:' :args:] (recur :func:)]
+                                   [:func:' (list& :arg: :args:)])
+
+                                 _
+                                 [:type: (;list)]))]]
+      (case :args:
+        #;Nil
+        (compiler;fail "Not a type application.")
+
+        _
+        (wrap [:func: (list;reverse :args:)])))))
+
+(do-template [ ]
+  [(def: #export 
+     (Matcher Type)
+     (lambda [:type:]
+       (case (type;un-name :type:)
+         (^=> (#;AppT :quant: :arg:)
+              {(type;un-alias :quant:) (#;NamedT ["lux" ] _)})
+         (:: compiler;Monad wrap :arg:)
+
+         _
+         (compiler;fail (format "Not "  " type: " (type;type-to-text :type:))))))]
+
+  [maybe "Maybe"]
+  [list  "List"]
+  )
+
+(def: (adjusted-idx env idx)
+  (-> Env Nat Nat)
+  (let [env-level (/+ +2 (dict;size env))
+        bound-level (/+ +2 idx)
+        bound-idx (%+ +2 idx)]
+    (|> env-level dec+ (-+ bound-level) (*+ +2) (++ bound-idx))))
+
+(def: #export (bound env)
+  (-> Env (Matcher AST))
+  (lambda [:type:]
+    (case :type:
+      (#;BoundT idx)
+      (case (dict;get (adjusted-idx env idx) env)
+        (#;Some poly-val)
+        (:: compiler;Monad wrap poly-val)
+
+        #;None
+        (compiler;fail (format "Unknown bound type: " (type;type-to-text :type:))))
+
+      _
+      (compiler;fail (format "Not a bound type: " (type;type-to-text :type:))))))
+
+(def: #export (var env var-id)
+  (-> Env Nat (Matcher Unit))
+  (lambda [:type:]
+    (case :type:
+      (^=> (#;BoundT idx)
+           (=+ var-id (adjusted-idx env idx)))
+      (:: compiler;Monad wrap [])
+
+      _
+      (compiler;fail (format "Not a bound type: " (type;type-to-text :type:))))))
+
+(def: #export (recur env)
+  (-> Env (Matcher Unit))
+  (lambda [:type:]
+    (do Monad
+      [[t-fun t-args] (apply :type:)]
+      (loop [base +0
+             :parts: (list& t-fun t-args)]
+        (case :parts:
+          #;Nil
+          (wrap [])
+          
+          (^=> (#;Cons (#;BoundT idx) :parts:')
+               {(adjusted-idx env idx)
+                idx'}
+               (=+ base idx'))
+          (recur (inc+ base) :parts:')
+
+          _
+          (compiler;fail (format "Type is not a recursive instance: " (type;type-to-text :type:)))))
+      )))
+
+## [Syntax]
+(def: #export (extend-env type-func type-vars env)
+  (-> AST (List AST) Env Env)
+  (case type-vars
+    #;Nil
+    env
+    
+    (#;Cons tvar type-vars')
+    (let [current-size (dict;size env)]
+      (|> env
+          (dict;put current-size type-func)
+          (dict;put (inc+ current-size) tvar)
+          (extend-env (` (#;AppT (~ type-func) (~ tvar))) type-vars')
+          ))))
+
+(syntax: #export (poly: {_ex-lev common;export-level}
+                   {[name env inputs] (s;form ($_ s;seq
+                                                  s;local-symbol
+                                                  s;local-symbol
+                                                  (s;many s;local-symbol)))}
+                   body)
+  (with-gensyms [g!body]
+    (let [g!inputs (List/map (|>. [""] ast;symbol) inputs)
+          g!name (ast;symbol ["" name])
+          g!env (ast;symbol ["" env])]
+      (wrap (;list (` (syntax: (~@ (common;gen-export-level _ex-lev)) ((~ g!name) (~@ (List/map (lambda [g!input] (` {(~ g!input) s;symbol}))
+                                                                                                g!inputs)))
+                        (do Monad
+                          [(~@ (List/join (List/map (lambda [g!input] (;list g!input (` (compiler;find-type-def (~ g!input)))))
+                                                    g!inputs)))
+                           (~' #let) [(~ g!env) (: Env (dict;new number;Hash))]
+                           (~ g!body) (: (Lux AST)
+                                         (loop [(~ g!env) (~ g!env)
+                                                (~@ (List/join (List/map (lambda [g!input] (;list g!input g!input))
+                                                                         g!inputs)))]
+                                           (let [(~ g!name) (~' recur)]
+                                             (~ body))))]
+                          ((~' wrap) (;list (~ g!body)))))))))))
+
+(def: (common-poly-name? poly-func)
+  (-> Text Bool)
+  (and (text;starts-with? "|" poly-func)
+       (text;ends-with? "|" poly-func)))
+
+(def: (derivation-name poly args)
+  (-> Text (List Text) (Maybe Text))
+  (if (common-poly-name? poly)
+    (case (text;sub +1 (dec+ (text;size poly)) poly)
+      (#;Some clean-poly)
+      (case (list;reverse args)
+        #;Nil
+        #;None
+
+        (#;Cons type #;Nil)
+        (#;Some (format type "/" clean-poly))
+
+        (#;Cons type args)
+        (#;Some (format type "/" clean-poly "@" (|> args list;reverse (text;join-with ",")))))
+      
+      #;None
+      #;None)
+    #;None))
+
+(syntax: #export (derived: {_ex-lev common;export-level}
+                   {?name (s;opt s;local-symbol)}
+                   {[poly-func poly-args] (s;either (s;form (s;seq s;symbol (s;many s;symbol)))
+                                                    (s;seq s;symbol (:: @ wrap (;list))))}
+                   {?custom-impl (s;opt s;any)})
+  (do @
+    [name (case ?name
+            (#;Some name)
+            (wrap name)
+
+            (^=> #;None
+                 {(derivation-name (product;right poly-func) (List/map product;right poly-args))
+                  (#;Some derived-name)})
+            (wrap derived-name)
+
+            _
+            (compiler;fail "derived: was given no explicit name, and can't generate one from given information."))
+     #let [impl (case ?custom-impl
+                  (#;Some custom-impl)
+                  custom-impl
+
+                  #;None
+                  (` ((~ (ast;symbol poly-func)) (~@ (List/map ast;symbol poly-args)))))]]
+    (wrap (;list (` (def: (~@ (common;gen-export-level _ex-lev))
+                      (~ (ast;symbol ["" name]))
+                      (~ impl)))))))
+
+## [Derivers]
+(def: #export (gen-type converter type-fun tvars type)
+  (-> (-> AST AST) AST (List AST) Type AST)
+  (let [type' (type;type-to-ast type)]
+    (case tvars
+      #;Nil
+      (converter type')
+
+      _
+      (` (All (~ type-fun) [(~@ tvars)]
+           (-> (~@ (List/map converter tvars))
+               (~ (converter (` ((~ type') (~@ tvars)))))))))))
diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux
new file mode 100644
index 000000000..b0506c5ed
--- /dev/null
+++ b/stdlib/source/lux/macro/poly/eq.lux
@@ -0,0 +1,103 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monad
+                [eq])
+       (data [text]
+             text/format
+             (struct [list "List/" Monad]
+                     [dict #+ Dict])
+             [number]
+             [product]
+             [bool]
+             [char]
+             [maybe])
+       [compiler #+ Monad with-gensyms]
+       (macro [ast]
+              [syntax #+ syntax: Syntax]
+              (syntax [common])
+              [poly #+ poly:])
+       [type]
+       ))
+
+## [Derivers]
+(poly: #export (|Eq| env :x:)
+  (let [->Eq (: (-> AST AST)
+                (lambda [.type.] (` (eq;Eq (~ .type.)))))]
+    (let% [ (do-template [  ]
+                     [(do @
+                        [_ ( :x:)]
+                        (wrap (` (: (~ (->Eq (` )))
+                                    ))))]
+
+                     [Unit poly;unit (lambda [(~' test) (~' input)] true)]
+                     [Bool poly;bool bool;Eq]
+                     [Nat  poly;nat  number;Eq]
+                     [Int  poly;int  number;Eq]
+                     [Frac poly;frac number;Eq]
+                     [Real poly;real number;Eq]
+                     [Char poly;char char;Eq]
+                     [Text poly;text text;Eq])]
+      ($_ compiler;either
+          ## Primitive types
+          
+          ## Variants
+          (with-gensyms [g!type-fun g!left g!right]
+            (do @
+              [[g!vars cases] (poly;variant :x:)
+               #let [new-env (poly;extend-env g!type-fun g!vars env)]
+               pattern-matching (mapM @
+                                      (lambda [[name :case:]]
+                                        (do @
+                                          [encoder (|Eq| new-env :case:)]
+                                          (wrap (list (` [((~ (ast;tag name)) (~ g!left))
+                                                          ((~ (ast;tag name)) (~ g!right))])
+                                                      (` ((~ encoder) (~ g!left) (~ g!right)))))))
+                                      cases)]
+              (wrap (` (: (~ (poly;gen-type ->Eq g!type-fun g!vars :x:))
+                          (lambda [(~@ g!vars)]
+                            (lambda [(~ g!left) (~ g!right)]
+                              (case [(~ g!left) (~ g!right)]
+                                (~@ (List/join pattern-matching)))))
+                          )))))
+          ## Tuples
+          (with-gensyms [g!type-fun g!left g!right]
+            (do @
+              [[g!vars members] (poly;tuple :x:)
+               #let [new-env (poly;extend-env g!type-fun g!vars env)]
+               pattern-matching (mapM @
+                                      (lambda [:member:]
+                                        (do @
+                                          [g!left (compiler;gensym "g!left")
+                                           g!right (compiler;gensym "g!right")
+                                           encoder (|Eq| new-env :member:)]
+                                          (wrap [g!left g!right encoder])))
+                                      members)
+               #let [.left. (` [(~@ (List/map product;left pattern-matching))])
+                     .right. (` [(~@ (List/map (|>. product;right product;left) pattern-matching))])]]
+              (wrap (` (: (~ (poly;gen-type ->Eq g!type-fun g!vars :x:))
+                          (lambda [(~@ g!vars)]
+                            (lambda [(~ g!left) (~ g!right)]
+                              (case [(~ g!left) (~ g!right)]
+                                [(~ .left.) (~ .right.)]
+                                (;;array (list (~@ (List/map (lambda [[g!left g!right g!encoder]]
+                                                               (` ((~ g!encoder) (~ g!left) (~ g!right))))
+                                                             pattern-matching)))))))
+                          )))
+              ))
+          ## Type applications
+          (do @
+            [[:func: :args:] (poly;apply :x:)
+             .func. (|Eq| env :func:)
+             .args. (mapM @ (|Eq| env) :args:)]
+            (wrap (` (: (~ (->Eq (type;type-to-ast :x:)))
+                        ((~ .func.) (~@ .args.))))))
+          ## Bound type-vars
+          (poly;bound env :x:)
+          ## If all else fails...
+          (compiler;fail (format "Can't create Eq for: " (type;type-to-text :x:)))
+          ))))
diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux
new file mode 100644
index 000000000..78b668f2c
--- /dev/null
+++ b/stdlib/source/lux/macro/poly/functor.lux
@@ -0,0 +1,126 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monad
+                [functor])
+       (data [text]
+             text/format
+             (struct [list "List/" Monad]
+                     [dict #+ Dict])
+             [number]
+             [product]
+             [bool]
+             [char]
+             [maybe]
+             [ident "Ident/" Codec]
+             error)
+       [compiler #+ Monad with-gensyms]
+       (macro [ast]
+              [syntax #+ syntax: Syntax]
+              (syntax [common])
+              [poly #+ poly:])
+       [type]
+       ))
+
+## [Derivers]
+(poly: #export (|Functor| env :x:)
+  (with-gensyms [g!type-fun g!func g!input]
+    (do @
+      [#let [g!map (' map)]
+       [g!vars _] (poly;polymorphic :x:)
+       #let [num-vars (list;size g!vars)
+             new-env (poly;extend-env g!type-fun g!vars env)]
+       _ (compiler;assert (>+ +0 num-vars)
+                      "Functors must have at least 1 type-variable.")]
+      (let [->Functor (: (-> AST AST)
+                         (lambda [.type.] (` (functor;Functor (~ .type.)))))
+            |elem| (: (-> AST (poly;Matcher AST))
+                      (lambda |elem| [value :type:]
+                        ($_ compiler;either
+                            ## Nothing to do.
+                            (do @
+                              [_ (poly;primitive :type:)]
+                              (wrap value))
+                            ## Type-var
+                            (do @
+                              [_ (poly;var new-env (dec+ num-vars) :type:)]
+                              (wrap (` ((~ g!func) (~ value)))))
+                            ## Tuples/records
+                            (do @
+                              [[g!vars members] (poly;tuple :x:)
+                               pm (mapM @
+                                        (lambda [:slot:]
+                                          (do @
+                                            [g!slot (compiler;gensym "g!slot")
+                                             body (|elem| g!slot :slot:)]
+                                            (wrap [g!slot body])))
+                                        members)]
+                              (wrap (` (case (~ g!input)
+                                         [(~@ (List/map product;left pm))]
+                                         [(~@ (List/map product;right pm))])
+                                       )))
+                            ## Recursion
+                            (do @
+                              [_ (poly;recur new-env :type:)]
+                              (wrap (` ((~ g!map) (~ g!func) (~ value)))))
+                            )))]
+        ($_ compiler;either
+            ## Variants
+            (do @
+              [[g!vars cases] (poly;variant :x:)
+               pattern-matching (mapM @
+                                      (lambda [[name :case:]]
+                                        (do @
+                                          [#let [analysis (` ((~ (ast;tag name)) (~ g!input)))]
+                                           synthesis (|elem| g!input :case:)]
+                                          (wrap (list analysis
+                                                      synthesis))))
+                                      cases)]
+              (wrap (` (: (~ (->Functor (type;type-to-ast :x:)))
+                          (struct (def: ((~ g!map) (~ g!func) (~ g!input))
+                                    (case (~ g!input)
+                                      (~@ (List/join pattern-matching)))))
+                          ))))
+            ## Tuples/Records
+            (do @
+              [[g!vars members] (poly;tuple :x:)
+               pm (mapM @
+                        (lambda [:slot:]
+                          (do @
+                            [g!slot (compiler;gensym "g!slot")
+                             body (|elem| g!slot :slot:)]
+                            (wrap [g!slot body])))
+                        members)]
+              (wrap (` (: (~ (->Functor (type;type-to-ast :x:)))
+                          (struct (def: ((~ g!map) (~ g!func) (~ g!input))
+                                    (case (~ g!input)
+                                      [(~@ (List/map product;left pm))]
+                                      [(~@ (List/map product;right pm))])))
+                          ))))
+            ## Functions
+            (with-gensyms [g!out]
+              (do @
+                [[g!vars [:ins: :out:]] (poly;function :x:)
+                 .out. (|elem| g!out :out:)
+                 g!ins (seqM @
+                             (list;repeat (list;size :ins:)
+                                          (compiler;gensym "g!arg")))]
+                (wrap (` (: (~ (->Functor (type;type-to-ast :x:)))
+                            (struct (def: ((~ g!map) (~ g!func) (~ g!input))
+                                      (lambda [(~@ g!ins)]
+                                        (let [(~ g!out) ((~ g!input) (~@ g!ins))]
+                                          (~ .out.))))))))))
+            ## No structure (as you'd expect from Identity)
+            (do @
+              [_ (poly;var new-env (dec+ num-vars) :x:)]
+              (wrap (` (: (~ (->Functor (type;type-to-ast :x:)))
+                          (struct (def: ((~ g!map) (~ g!func) (~ g!input))
+                                    ((~ g!func) (~ g!input))))))))
+            ## Failure...
+            (compiler;fail (format "Can't create Functor for: " (type;type-to-text :x:)))
+            ))
+      )))
diff --git a/stdlib/source/lux/macro/poly/text-encoder.lux b/stdlib/source/lux/macro/poly/text-encoder.lux
new file mode 100644
index 000000000..49d06daf4
--- /dev/null
+++ b/stdlib/source/lux/macro/poly/text-encoder.lux
@@ -0,0 +1,126 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monad
+                [codec])
+       (data [text]
+             text/format
+             (struct [list "List/" Monad]
+                     [dict #+ Dict])
+             [number]
+             [product]
+             [bool]
+             [char]
+             [maybe]
+             [ident "Ident/" Codec]
+             error)
+       [compiler #+ Monad with-gensyms]
+       (macro [ast]
+              [syntax #+ syntax: Syntax]
+              (syntax [common])
+              [poly #+ poly:])
+       [type]
+       ))
+
+## [Derivers]
+(poly: #export (|Codec@Text//encode| env :x:)
+  (let [->Codec//encode (: (-> AST AST)
+                           (lambda [.type.] (` (-> (~ .type.) Text))))]
+    (let% [ (do-template [  ]
+                     [(do @
+                        [_ ( :x:)]
+                        (wrap (` (: (~ (->Codec//encode (` )))
+                                    (~' )))))]
+
+                     [Unit poly;unit (lambda [_0] "[]")]
+                     [Bool poly;bool (:: bool;Codec encode)]
+                     [Nat  poly;nat  (:: number;Codec encode)]
+                     [Int  poly;int  (:: number;Codec encode)]
+                     [Frac poly;frac (:: number;Codec encode)]
+                     [Real poly;real (:: number;Codec encode)]
+                     [Char poly;char (:: char;Codec encode)]
+                     [Text poly;text (:: text;Codec encode)])]
+      ($_ compiler;either
+          ## Primitives
+          
+          ## Variants
+          (with-gensyms [g!type-fun g!case g!input]
+            (do @
+              [[g!vars cases] (poly;variant :x:)
+               #let [new-env (poly;extend-env g!type-fun g!vars env)]
+               pattern-matching (mapM @
+                                      (lambda [[name :case:]]
+                                        (do @
+                                          [encoder (|Codec@Text//encode| new-env :case:)]
+                                          (wrap (list (` ((~ (ast;tag name)) (~ g!case)))
+                                                      (` (format "(#"
+                                                                 (~ (ast;text (Ident/encode name)))
+                                                                 " "
+                                                                 ((~ encoder) (~ g!case))
+                                                                 ")"))))))
+                                      cases)]
+              (wrap (` (: (~ (poly;gen-type ->Codec//encode g!type-fun g!vars :x:))
+                          (lambda [(~@ g!vars)]
+                            (lambda [(~ g!input)]
+                              (case (~ g!input)
+                                (~@ (List/join pattern-matching)))))
+                          )))))
+          ## Records
+          (with-gensyms [g!type-fun g!case g!input]
+            (do @
+              [[g!vars slots] (poly;record :x:)
+               #let [new-env (poly;extend-env g!type-fun g!vars env)]
+               synthesis (mapM @
+                               (lambda [[name :slot:]]
+                                 (do @
+                                   [encoder (|Codec@Text//encode| new-env :slot:)]
+                                   (wrap (` (format "#"
+                                                    (~ (ast;text (Ident/encode name)))
+                                                    " "
+                                                    ((~ encoder) (get@ (~ (ast;tag name)) (~ g!input))))))))
+                               slots)]
+              (wrap (` (: (~ (poly;gen-type ->Codec//encode g!type-fun g!vars :x:))
+                          (lambda [(~@ g!vars)]
+                            (lambda [(~ g!input)]
+                              (format "{" (~@ (list;interpose (' " ") synthesis)) "}")))
+                          )))))
+          ## Tuples
+          (with-gensyms [g!type-fun g!case g!input]
+            (do @
+              [[g!vars members] (poly;tuple :x:)
+               #let [new-env (poly;extend-env g!type-fun g!vars env)]
+               parts (mapM @
+                           (lambda [:member:]
+                             (do @
+                               [g!member (compiler;gensym "g!member")
+                                encoder (|Codec@Text//encode| new-env :member:)]
+                               (wrap [g!member encoder])))
+                           members)
+               #let [analysis (` [(~@ (List/map product;left parts))])
+                     synthesis (List/map (lambda [[g!member g!encoder]]
+                                           (` ((~ g!encoder) (~ g!member))))
+                                         parts)]]
+              (wrap (` (: (~ (poly;gen-type ->Codec//encode g!type-fun g!vars :x:))
+                          (lambda [(~@ g!vars)]
+                            (lambda [(~ g!input)]
+                              (case (~ g!input)
+                                (~ analysis)
+                                (format "[" (~@ (list;interpose (' " ") synthesis)) "]"))))
+                          )))
+              ))
+          ## Type applications
+          (do @
+            [[:func: :args:] (poly;apply :x:)
+             .func. (|Codec@Text//encode| env :func:)
+             .args. (mapM @ (|Codec@Text//encode| env) :args:)]
+            (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+                        ((~ .func.) (~@ .args.))))))
+          ## Bound type-variables
+          (poly;bound env :x:)
+          ## Failure...
+          (compiler;fail (format "Can't create Text encoder for: " (type;type-to-text :x:)))
+          ))))
diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux
new file mode 100644
index 000000000..367dc10b6
--- /dev/null
+++ b/stdlib/source/lux/macro/syntax.lux
@@ -0,0 +1,472 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  [lux #- not default]
+  (lux [compiler #+ Monad with-gensyms]
+       (control functor
+                applicative
+                monad
+                eq)
+       (data [bool]
+             [char]
+             [number]
+             [text "Text/" Monoid]
+             [ident]
+             (struct [list #* "" Functor Fold "List/" Monoid])
+             [product]
+             error))
+  (.. [ast]))
+
+## [Utils]
+(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]
+(type: #export (Syntax a)
+  (-> (List AST) (Error [(List AST) a])))
+
+## [Structures]
+(struct: #export _ (Functor Syntax)
+  (def: (map f ma)
+    (lambda [tokens]
+      (case (ma tokens)
+        (#;Left msg)
+        (#;Left msg)
+
+        (#;Right [tokens' a])
+        (#;Right [tokens' (f a)])))))
+
+(struct: #export _ (Applicative Syntax)
+  (def: functor Functor)
+
+  (def: (wrap x tokens)
+    (#;Right [tokens x]))
+
+  (def: (apply ff fa)
+    (lambda [tokens]
+      (case (ff tokens)
+        (#;Right [tokens' f])
+        (case (fa tokens')
+          (#;Right [tokens'' a])
+          (#;Right [tokens'' (f a)])
+
+          (#;Left msg)
+          (#;Left msg))
+
+        (#;Left msg)
+        (#;Left msg)))))
+
+(struct: #export _ (Monad Syntax)
+  (def: applicative Applicative)
+
+  (def: (join mma)
+    (lambda [tokens]
+      (case (mma tokens)
+        (#;Left msg)
+        (#;Left msg)
+
+        (#;Right [tokens' ma])
+        (ma tokens')))))
+
+## [Utils]
+(def: (remaining-inputs asts)
+  (-> (List AST) Text)
+  ($_ Text/append " | Remaining input: "
+      (|> asts (map ast;ast-to-text) (interpose " ") (text;join-with ""))))
+
+## [Syntaxs]
+(def: #export any
+  {#;doc "Just returns the next input without applying any logic."}
+  (Syntax AST)
+  (lambda [tokens]
+    (case tokens
+      #;Nil                (#;Left "There are no tokens to parse!")
+      (#;Cons [t tokens']) (#;Right [tokens' t]))))
+
+(do-template [      ]
+  [(def: #export 
+     (Syntax )
+     (lambda [tokens]
+       (case tokens
+         (#;Cons [[_ ( x)] tokens'])
+         (#;Right [tokens' x])
+
+         _
+         (#;Left ($_ Text/append "Can't parse "  (remaining-inputs tokens))))))
+
+   (def: #export ( v)
+     (->  (Syntax Bool))
+     (lambda [tokens]
+       (case tokens
+         (#;Cons [[_ ( x)] tokens'])
+         (let [is-it? (::  = v x)
+               remaining (if is-it?
+                           tokens'
+                           tokens)]
+           (#;Right [remaining is-it?]))
+
+         _
+         (#;Right [tokens false]))))
+
+   (def: #export ( v)
+     (->  (Syntax Unit))
+     (lambda [tokens]
+       (case tokens
+         (#;Cons [[_ ( x)] tokens'])
+         (if (::  = v x)
+           (#;Right [tokens' []])
+           (#;Left ($_ Text/append "Expected a "  " but instead got " (ast;ast-to-text [_ ( x)]) (remaining-inputs tokens))))
+
+         _
+         (#;Left ($_ Text/append "Can't parse "  (remaining-inputs tokens))))))]
+
+  [  bool   bool?   bool!  Bool   #;BoolS   bool;Eq "bool"]
+  [   nat    nat?    nat!   Nat    #;NatS  number;Eq "nat"]
+  [   int    int?    int!   Int    #;IntS  number;Eq "int"]
+  [  real   real?   real!  Real   #;RealS number;Eq "real"]
+  [  char   char?   char!  Char   #;CharS   char;Eq "char"]
+  [  text   text?   text!  Text   #;TextS   text;Eq "text"]
+  [symbol symbol? symbol! Ident #;SymbolS ident;Eq "symbol"]
+  [   tag    tag?    tag! Ident    #;TagS ident;Eq "tag"]
+  )
+
+(def: #export (assert v message)
+  (-> Bool Text (Syntax Unit))
+  (lambda [tokens]
+    (if v
+      (#;Right [tokens []])
+      (#;Left ($_ Text/append message (remaining-inputs tokens))))))
+
+(do-template [  ]
+  [(def: #export 
+     (Syntax Int)
+     (do Monad
+       [n int
+        _ (assert ( 0 n) )]
+       (wrap n)))]
+
+  [pos-int > "Expected a positive integer: N > 0"]
+  [neg-int < "Expected a negative integer: N < 0"]
+  )
+
+(do-template [  ]
+  [(def: #export 
+     (Syntax Text)
+     (lambda [tokens]
+       (case tokens
+         (#;Cons [[_ ( ["" x])] tokens'])
+         (#;Right [tokens' x])
+
+         _
+         (#;Left ($_ Text/append "Can't parse "  (remaining-inputs tokens))))))]
+
+  [local-symbol #;SymbolS "local symbol"]
+  [   local-tag #;TagS    "local tag"]
+  )
+
+(do-template [  ]
+  [(def: #export ( p)
+     (All [a]
+       (-> (Syntax a) (Syntax a)))
+     (lambda [tokens]
+       (case tokens
+         (#;Cons [[_ ( members)] tokens'])
+         (case (p members)
+           (#;Right [#;Nil x]) (#;Right [tokens' x])
+           _                   (#;Left ($_ Text/append "Syntax was expected to fully consume "  (remaining-inputs tokens))))
+
+         _
+         (#;Left ($_ Text/append "Can't parse "  (remaining-inputs tokens))))))]
+
+  [ form  #;FormS "form"]
+  [tuple #;TupleS "tuple"]
+  )
+
+(def: #export (record p)
+  (All [a]
+    (-> (Syntax a) (Syntax a)))
+  (lambda [tokens]
+    (case tokens
+      (#;Cons [[_ (#;RecordS pairs)] tokens'])
+      (case (p (join-pairs pairs))
+        (#;Right [#;Nil x]) (#;Right [tokens' x])
+        _                   (#;Left ($_ Text/append "Syntax was expected to fully consume record" (remaining-inputs tokens))))
+
+      _
+      (#;Left ($_ Text/append "Can't parse record" (remaining-inputs tokens))))))
+
+(def: #export (opt p)
+  {#;doc "Optionality combinator."}
+  (All [a]
+    (-> (Syntax a) (Syntax (Maybe a))))
+  (lambda [tokens]
+    (case (p tokens)
+      (#;Left _)            (#;Right [tokens #;None])
+      (#;Right [tokens' x]) (#;Right [tokens' (#;Some x)]))))
+
+(def: #export (run tokens p)
+  (All [a]
+    (-> (List AST) (Syntax a) (Error [(List AST) a])))
+  (p tokens))
+
+(def: #export (some p)
+  {#;doc "0-or-more combinator."}
+  (All [a]
+    (-> (Syntax a) (Syntax (List a))))
+  (lambda [tokens]
+    (case (p tokens)
+      (#;Left _)            (#;Right [tokens (list)])
+      (#;Right [tokens' x]) (run tokens'
+                                 (do Monad
+                                   [xs (some p)]
+                                   (wrap (list& x xs)))
+                                 ))))
+
+(def: #export (many p)
+  {#;doc "1-or-more combinator."}
+  (All [a]
+    (-> (Syntax a) (Syntax (List a))))
+  (do Monad
+    [x p
+     xs (some p)]
+    (wrap (list& x xs))))
+
+(def: #export (seq p1 p2)
+  {#;doc "Sequencing combinator."}
+  (All [a b]
+    (-> (Syntax a) (Syntax b) (Syntax [a b])))
+  (do Monad
+    [x1 p1
+     x2 p2]
+    (wrap [x1 x2])))
+
+(def: #export (alt p1 p2)
+  {#;doc "Heterogeneous alternative combinator."}
+  (All [a b]
+    (-> (Syntax a) (Syntax b) (Syntax (| a b))))
+  (lambda [tokens]
+    (case (p1 tokens)
+      (#;Right [tokens' x1]) (#;Right [tokens' (+0 x1)])
+      (#;Left _)             (run tokens
+                                  (do Monad
+                                    [x2 p2]
+                                    (wrap (+1 x2))))
+      )))
+
+(def: #export (either pl pr)
+  {#;doc "Homogeneous alternative combinator."}
+  (All [a]
+    (-> (Syntax a) (Syntax a) (Syntax a)))
+  (lambda [tokens]
+    (case (pl tokens)
+      (#;Left _) (pr tokens)
+      output     output
+      )))
+
+(def: #export end
+  {#;doc "Ensures there are no more inputs."}
+  (Syntax Unit)
+  (lambda [tokens]
+    (case tokens
+      #;Nil (#;Right [tokens []])
+      _     (#;Left ($_ Text/append "Expected list of tokens to be empty!" (remaining-inputs tokens))))))
+
+(def: #export end?
+  {#;doc "Checks whether there are no more inputs."}
+  (Syntax Bool)
+  (lambda [tokens]
+    (case tokens
+      #;Nil (#;Right [tokens true])
+      _     (#;Right [tokens false]))))
+
+(def: #export (exactly n p)
+  (All [a] (-> Nat (Syntax a) (Syntax (List a))))
+  (if (>+ +0 n)
+    (do Monad
+      [x p
+       xs (exactly (dec+ n) p)]
+      (wrap (#;Cons x xs)))
+    (:: Monad wrap (list))))
+
+(def: #export (at-least n p)
+  (All [a] (-> Nat (Syntax a) (Syntax (List a))))
+  (do Monad
+    [min (exactly n p)
+     extra (some p)]
+    (wrap (List/append min extra))))
+
+(def: #export (at-most n p)
+  (All [a] (-> Nat (Syntax a) (Syntax (List a))))
+  (if (>+ +0 n)
+    (lambda [input]
+      (case (p input)
+        (#;Left msg)
+        (#;Right [input (list)])
+
+        (#;Right [input' x])
+        (run input'
+             (do Monad
+               [xs (at-most (dec+ n) p)]
+               (wrap (#;Cons x xs))))
+        ))
+    (:: Monad wrap (list))))
+
+(def: #export (between from to p)
+  (All [a] (-> Nat Nat (Syntax a) (Syntax (List a))))
+  (do Monad
+    [min-xs (exactly from p)
+     max-xs (at-most (-+ from to) p)]
+    (wrap (:: Monad join (list min-xs max-xs)))))
+
+(def: #export (sep-by sep p)
+  {#;doc "Parsers instances of 'p' that are separated by instances of 'sep'."}
+  (All [a b] (-> (Syntax b) (Syntax a) (Syntax (List a))))
+  (do Monad
+    [?x (opt p)]
+    (case ?x
+      #;None
+      (wrap #;Nil)
+      
+      (#;Some x)
+      (do @
+        [xs' (some (seq sep p))]
+        (wrap (#;Cons x (map product;right xs'))))
+      )))
+
+(def: #export (not p)
+  (All [a] (-> (Syntax a) (Syntax Unit)))
+  (lambda [input]
+    (case (p input)
+      (#;Left msg)
+      (#;Right [input []])
+      
+      _
+      (#;Left "Expected to fail; yet succeeded."))))
+
+(def: #export (fail message)
+  (All [a] (-> Text (Syntax a)))
+  (lambda [input]
+    (#;Left message)))
+
+(def: #export (default value parser)
+  {#;doc "If the given parser fails, returns the default value."}
+  (All [a] (-> a (Syntax a) (Syntax a)))
+  (lambda [input]
+    (case (parser input)
+      (#;Left error)
+      (#;Right [input value])
+
+      (#;Right [input' output])
+      (#;Right [input' output]))))
+
+(def: #export (on compiler meta)
+  (All [a] (-> Compiler (Lux a) (Syntax a)))
+  (lambda [input]
+    (case (meta compiler)
+      (#;Left error)
+      (#;Left error)
+
+      (#;Right [_ value])
+      (#;Right [input value])
+      )))
+
+(def: #export (local local-inputs syntax)
+  (All [a] (-> (List AST) (Syntax a) (Syntax a)))
+  (lambda [real-inputs]
+    (case (syntax local-inputs)
+      (#;Left error)
+      (#;Left error)
+
+      (#;Right [unconsume-inputs value])
+      (case unconsume-inputs
+        #;Nil
+        (#;Right [real-inputs value])
+
+        _
+        (#;Left "Unconsumed inputs.")))))
+
+## [Syntax]
+(def: #hidden text.join-with text;join-with)
+
+(macro: #export (syntax: tokens)
+  {#;doc (doc "A more advanced way to define macros than macro:."
+              "The inputs to the macro can be parsed in complex ways through the use of syntax parsers."
+              "The macro body is also (implicitly) run in the Monad, to save some typing."
+              "Also, the compiler state can be accessed through the *compiler* binding."
+              (syntax: #export (object [#let [imports (class-imports *compiler*)]]
+                                 [#let [class-vars (list)]]
+                                 [super (opt (super-class-decl^ imports class-vars))]
+                                 [interfaces (tuple (some (super-class-decl^ imports class-vars)))]
+                                 [constructor-args (constructor-args^ imports class-vars)]
+                                 [methods (some (overriden-method-def^ imports))])
+                (let [def-code ($_ Text/append "anon-class:"
+                                   (spaced (list (super-class-decl$ (;default object-super-class super))
+                                                 (with-brackets (spaced (map super-class-decl$ interfaces)))
+                                                 (with-brackets (spaced (map constructor-arg$ constructor-args)))
+                                                 (with-brackets (spaced (map (method-def$ id) methods))))))]
+                  (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))))}
+  (let [[exported? tokens] (case tokens
+                             (^ (list& [_ (#;TagS ["" "export"])] tokens'))
+                             [true tokens']
+
+                             _
+                             [false tokens])
+        ?parts (: (Maybe [Text (List AST) AST AST])
+                  (case tokens
+                    (^ (list [_ (#;FormS (list& [_ (#;SymbolS ["" name])] args))]
+                             body))
+                    (#;Some name args (` {}) body)
+
+                    (^ (list [_ (#;FormS (list& [_ (#;SymbolS ["" name])] args))]
+                             meta-data
+                             body))
+                    (#;Some name args meta-data body)
+
+                    _
+                    #;None))]
+    (case ?parts
+      (#;Some [name args meta body])
+      (with-gensyms [g!tokens g!body g!msg]
+        (do Monad
+          [vars+parsers (mapM Monad
+                              (: (-> AST (Lux [AST AST]))
+                                 (lambda [arg]
+                                   (case arg
+                                     (^ [_ (#;RecordS (list [var parser]))])
+                                     (wrap [var parser])
+
+                                     [_ (#;SymbolS var-name)]
+                                     (wrap [(ast;symbol var-name) (` any)])
+
+                                     _
+                                     (compiler;fail "Syntax pattern expects records or symbols."))))
+                              args)
+           #let [g!state (ast;symbol ["" "*compiler*"])
+                 g!end (ast;symbol ["" ""])
+                 error-msg (ast;text (Text/append "Wrong syntax for " name))
+                 export-ast (: (List AST) (if exported? (list (' #export)) (list)))]]
+          (wrap (list (` (macro: (~@ export-ast) ((~ (ast;symbol ["" name])) (~ g!tokens))
+                           (~ meta)
+                           (lambda [(~ g!state)]
+                             (;_lux_case (run (~ g!tokens)
+                                              (: (Syntax (Lux (List AST)))
+                                                 (do Monad
+                                                   [(~@ (join-pairs vars+parsers))
+                                                    (~ g!end) end]
+                                                   ((~' wrap) (do Monad
+                                                                []
+                                                                (~ body))))))
+                               (#;Right [(~ g!tokens) (~ g!body)])
+                               ((~ g!body) (~ g!state))
+
+                               (#;Left (~ g!msg))
+                               (#;Left (text.join-with ": " (list (~ error-msg) (~ g!msg))))))))))))
+      
+      _
+      (compiler;fail "Wrong syntax for syntax:"))))
diff --git a/stdlib/source/lux/macro/syntax/common.lux b/stdlib/source/lux/macro/syntax/common.lux
new file mode 100644
index 000000000..743768fe6
--- /dev/null
+++ b/stdlib/source/lux/macro/syntax/common.lux
@@ -0,0 +1,164 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monad)
+       (data (struct [list])
+             text/format)
+       [compiler]
+       (macro [ast]
+              ["s" syntax #+ syntax: Syntax])))
+
+## Exports
+(type: #export Export-Level
+  #Exported
+  #Hidden)
+
+(def: #export export-level
+  (Syntax (Maybe Export-Level))
+  (s;opt (s;alt (s;tag! ["" "export"])
+                (s;tag! ["" "hidden"]))))
+
+(def: #export (gen-export-level ?el)
+  (-> (Maybe Export-Level) (List AST))
+  (case ?el
+    #;None
+    (list)
+
+    (#;Some #Exported)
+    (list (' #export))
+
+    (#;Some #Hidden)
+    (list (' #hidden))))
+
+## Declarations
+(type: #export Decl
+  {#decl-name Text
+   #decl-args (List Text)})
+
+(def: #export decl
+  (s;either (s;seq s;local-symbol
+                   (:: s;Monad wrap (list)))
+            (s;form (s;seq s;local-symbol
+                           (s;many s;local-symbol)))))
+
+## Definitions
+(type: #export Def-Syntax
+  {#def-name Text
+   #def-type (Maybe AST)
+   #def-value AST
+   #def-meta (List [Ident AST])
+   #def-args (List Text)
+   })
+
+(def: check^
+  (Syntax [(Maybe AST) AST])
+  (s;either (s;form (do s;Monad
+                      [_ (s;symbol! ["lux" "_lux_:"])
+                       type s;any
+                       value s;any]
+                      (wrap [(#;Some type) value])))
+            (s;seq (:: s;Monad wrap #;None)
+                   s;any)))
+
+(def: _def-meta-tag^
+  (Syntax Ident)
+  (s;tuple (s;seq s;text s;text)))
+
+(def: (_def-meta^ _)
+  (-> Top (Syntax (List [Ident AST])))
+  (s;alt (s;tag! ["lux" "Nil"])
+         (s;form (do s;Monad
+                   [_ (s;tag! ["lux" "Cons"])
+                    [head tail] (s;seq (s;tuple (s;seq _def-meta-tag^ s;any))
+                                       (_def-meta^ []))]
+                   (wrap [head tail])))
+         ))
+
+(def: (flat-list^ _)
+  (-> Top (Syntax (List AST)))
+  (s;either (do s;Monad
+              [_ (s;tag! ["lux" "Nil"])]
+              (wrap (list)))
+            (s;form (do s;Monad
+                      [_ (s;tag! ["lux" "Cons"])
+                       [head tail] (s;tuple (s;seq s;any s;any))
+                       tail (s;local (list tail) (flat-list^ []))]
+                      (wrap (#;Cons head tail))))))
+
+(def: list-meta^
+  (Syntax (List AST))
+  (s;form (do s;Monad
+            [_ (s;tag! ["lux" "ListM"])]
+            (flat-list^ []))))
+
+(def: text-meta^
+  (Syntax Text)
+  (s;form (do s;Monad
+            [_ (s;tag! ["lux" "TextM"])]
+            s;text)))
+
+(def: (find-def-args meta-data)
+  (-> (List [Ident AST]) (List Text))
+  (default (list)
+    (list;find (lambda [[tag value]]
+                 (case tag
+                   (^=> ["lux" "func-args"]
+                        {(s;run (list value) list-meta^)
+                         (#;Right [_ args])}
+                        {(s;run args (s;some text-meta^))
+                         (#;Right [_ args])})
+                   (#;Some args)
+
+                   _
+                   #;None))
+               meta-data)))
+
+(def: #export (def compiler)
+  (-> Compiler (Syntax Def-Syntax))
+  (do s;Monad
+    [def-raw s;any
+     me-def-raw (s;on compiler
+                      (compiler;macro-expand-all def-raw))]
+    (s;local me-def-raw
+             (s;form (do @
+                       [_ (s;symbol! ["lux" "_lux_def"])
+                        def-name s;local-symbol
+                        [?def-type def-value] check^
+                        def-meta s;any
+                        def-meta (s;local (list def-meta)
+                                          (_def-meta^ []))
+                        #let [def-args (find-def-args def-meta)]]
+                       (wrap {#def-name def-name
+                              #def-type ?def-type
+                              #def-meta def-meta
+                              #def-value def-value
+                              #def-args def-args}))))))
+
+(def: #export (typed-de compiler)
+  (-> Compiler (Syntax Def-Syntax))
+  (do s;Monad
+    [_def (def compiler)
+     _ (case (get@ #def-type _def)
+         (#;Some _)
+         (wrap [])
+
+         #;None
+         (s;fail "Typed def must have a type!")
+         )]
+    (wrap _def)))
+
+(def: #export def-meta
+  (Syntax (List [Ident AST]))
+  (s;record (s;some (s;seq s;tag s;any))))
+
+(def: #export typed-arg
+  (Syntax [Text AST])
+  (s;record (s;seq s;local-symbol s;any)))
+
+(def: #export type-params
+  (Syntax (List Text))
+  (s;tuple (s;some s;local-symbol)))
diff --git a/stdlib/source/lux/macro/template.lux b/stdlib/source/lux/macro/template.lux
new file mode 100644
index 000000000..0288f05cf
--- /dev/null
+++ b/stdlib/source/lux/macro/template.lux
@@ -0,0 +1,54 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monad)
+       (data (struct [list "" Monad Fold]
+                     [dict #+ Dict])
+             [text])
+       [compiler]
+       (macro [ast]
+              ["s" syntax #+ syntax: Syntax]
+              (syntax [common]))))
+
+## [Syntax]
+(def: decl^
+  (Syntax [Text (List Text)])
+  (s;form (s;seq s;local-symbol (s;many s;local-symbol))))
+
+(def: (prepare bindings template)
+  (-> (Dict Text AST) AST AST)
+  (case template
+    (^=> [_ (#;SymbolS "" name)]
+         {(dict;get name bindings) (#;Some found)})
+    found
+    
+    (^template []
+      [meta ( parts)]
+      [meta ( (map (prepare bindings ) parts))])
+    ([#;FormS]
+     [#;TupleS])
+
+    
+    [meta (#;RecordS pairs)]
+    [meta (#;RecordS (map (lambda [[slot value]]
+                            [(prepare bindings slot)
+                             (prepare bindings value)])
+                          pairs))]
+
+    _
+    template
+    ))
+
+(syntax: #export (template: {_ex-lev common;export-level} {[name args] decl^} template)
+  (let [bindings (fold (lambda [arg bindings]
+                         (dict;put arg (` ((~' ~) (~ (ast;symbol ["" arg])))) bindings))
+                       (: (Dict Text AST) (dict;new text;Hash))
+                       args)]
+    (wrap (list (` (syntax: (~@ (common;gen-export-level _ex-lev)) ((~ (ast;symbol ["" name]))
+                                                                (~@ (map (|>. [""] ast;symbol) args)))
+                     ((~' wrap) (list (` (~ (prepare bindings template)))))))))
+    ))
diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux
new file mode 100644
index 000000000..ffc13818f
--- /dev/null
+++ b/stdlib/source/lux/math.lux
@@ -0,0 +1,158 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module: {#;doc "Common numerical operations."}
+  lux
+  (lux (control monad)
+       (data (struct [list "" Fold])
+             [number "Int/" Number]
+             [product]
+             text/format)
+       host
+       [compiler]
+       (macro ["s" syntax #+ syntax: Syntax "Syntax/" Functor]
+              [ast])))
+
+## [Values]
+(do-template [ ]
+  [(def: #export 
+     Real
+     (_lux_proc ["jvm" ] []))]
+
+  [e  "getstatic:java.lang.Math:E"]
+  [pi "getstatic:java.lang.Math:PI"]
+  )
+
+(def: #export tau Real 6.28318530717958647692)
+
+(do-template [ ]
+  [(def: #export ( n)
+     (-> Real Real)
+     (_lux_proc ["jvm" ] [n]))]
+
+  [cos   "invokestatic:java.lang.Math:cos:double"]
+  [sin   "invokestatic:java.lang.Math:sin:double"]
+  [tan   "invokestatic:java.lang.Math:tan:double"]
+
+  [acos  "invokestatic:java.lang.Math:acos:double"]
+  [asin  "invokestatic:java.lang.Math:asin:double"]
+  [atan  "invokestatic:java.lang.Math:atan:double"]
+  
+  [cosh  "invokestatic:java.lang.Math:cosh:double"]
+  [sinh  "invokestatic:java.lang.Math:sinh:double"]
+  [tanh  "invokestatic:java.lang.Math:tanh:double"]
+
+  [exp   "invokestatic:java.lang.Math:exp:double"]
+  [log   "invokestatic:java.lang.Math:log:double"]
+  
+  [cbrt  "invokestatic:java.lang.Math:cbrt:double"]
+  [sqrt  "invokestatic:java.lang.Math:sqrt:double"]
+
+  [degrees "invokestatic:java.lang.Math:toDegrees:double"]
+  [radians "invokestatic:java.lang.Math:toRadians:double"]
+  )
+
+(do-template [ ]
+  [(def: #export ( n)
+     (-> Real Real)
+     (_lux_proc ["jvm" ] [n]))]
+
+  [ceil  "invokestatic:java.lang.Math:ceil:double"]
+  [floor "invokestatic:java.lang.Math:floor:double"]
+  )
+
+(def: #export (round n)
+  (-> Real Real)
+  (int-to-real (_lux_proc ["jvm" "invokestatic:java.lang.Math:round:double"] [n])))
+
+(do-template [ ]
+  [(def: #export ( param subject)
+     (-> Real Real Real)
+     (_lux_proc ["jvm" ] [subject param]))]
+
+  [atan2 "invokestatic:java.lang.Math:atan2:double,double"]
+  [pow   "invokestatic:java.lang.Math:pow:double,double"]
+  )
+
+(def: (gcd' a b)
+  (-> Int Int Int)
+  (case b
+    0 a
+    _ (gcd' b (% b a))))
+
+(def: #export (gcd a b)
+  {#;doc "Greatest Common Divisor."}
+  (-> Int Int Int)
+  (gcd' (Int/abs a) (Int/abs b)))
+
+(def: #export (lcm x y)
+  {#;doc "Least Common Multiple."}
+  (-> Int Int Int)
+  (case [x y]
+    (^or [_ 0] [0 _])
+    0
+
+    _
+    (|> x (/ (gcd x y)) (* y) Int/abs)
+    ))
+
+## [Syntax]
+(type: #rec Infix
+  (#Const AST)
+  (#Call (List AST))
+  (#Infix Infix AST Infix))
+
+(def: (infix^ _)
+  (-> Unit (Syntax Infix))
+  ($_ s;alt
+      ($_ s;either
+          (Syntax/map ast;bool s;bool)
+          (Syntax/map ast;int s;int)
+          (Syntax/map ast;real s;real)
+          (Syntax/map ast;char s;char)
+          (Syntax/map ast;text s;text)
+          (Syntax/map ast;symbol s;symbol)
+          (Syntax/map ast;tag s;tag))
+      (s;form (s;many s;any))
+      (s;tuple (s;either (do s;Monad
+                           [_ (s;tag! ["" "and"])
+                            init-subject (infix^ [])
+                            init-op s;any
+                            init-param (infix^ [])
+                            steps (s;some (s;seq s;any (infix^ [])))]
+                           (wrap (product;right (fold (lambda [[op param] [subject [_subject _op _param]]]
+                                                        [param [(#Infix _subject _op _param)
+                                                                (` and)
+                                                                (#Infix subject op param)]])
+                                                      [init-param [init-subject init-op init-param]]
+                                                      steps))))
+                         (do s;Monad
+                           [_ (wrap [])
+                            init-subject (infix^ [])
+                            init-op s;any
+                            init-param (infix^ [])
+                            steps (s;some (s;seq s;any (infix^ [])))]
+                           (wrap (fold (lambda [[op param] [_subject _op _param]]
+                                         [(#Infix _subject _op _param) op param])
+                                       [init-subject init-op init-param]
+                                       steps)))
+                         ))
+      ))
+
+(def: (infix-to-prefix infix)
+  (-> Infix AST)
+  (case infix
+    (#Const value)
+    value
+    
+    (#Call parts)
+    (ast;form parts)
+    
+    (#Infix left op right)
+    (` ((~ op) (~ (infix-to-prefix right)) (~ (infix-to-prefix left))))
+    ))
+
+(syntax: #export (infix {expr (infix^ [])})
+  (wrap (list (infix-to-prefix expr))))
diff --git a/stdlib/source/lux/math/complex.lux b/stdlib/source/lux/math/complex.lux
new file mode 100644
index 000000000..eb7796bb2
--- /dev/null
+++ b/stdlib/source/lux/math/complex.lux
@@ -0,0 +1,291 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux [math]
+       (control eq
+                [ord]
+                number
+                codec
+                monad)
+       (data [number "r:" Number Codec]
+             [text "Text/" Monoid]
+             error
+             maybe
+             (struct [list "List/" Monad]))
+       [compiler]
+       (macro [ast]
+              ["s" syntax #+ syntax: Syntax])))
+
+## Based on org.apache.commons.math4.complex.Complex
+
+(type: #export Complex
+  {#real Real
+   #imaginary Real})
+
+(syntax: #export (complex real {?imaginary (s;opt s;any)})
+  (wrap (list (` {#;;real (~ real)
+                  #;;imaginary (~ (default (` 0.0)
+                                    ?imaginary))}))))
+
+(def: #export i Complex (complex 0.0 1.0))
+
+(def: #export one Complex (complex 1.0 0.0))
+
+(def: #export zero Complex (complex 0.0 0.0))
+
+(def: #export (c= param input)
+  (-> Complex Complex Bool)
+  (and (=. (get@ #real param)
+           (get@ #real input))
+       (=. (get@ #imaginary param)
+           (get@ #imaginary input))))
+
+(do-template [ ]
+  [(def: #export ( param input)
+     (-> Complex Complex Complex)
+     {#real ( (get@ #real param)
+                  (get@ #real input))
+      #imaginary ( (get@ #imaginary param)
+                       (get@ #imaginary input))})]
+
+  [c+ +.]
+  [c- -.]
+  )
+
+(struct: #export _ (Eq Complex)
+  (def: = c=))
+
+(def: #export negate
+  (-> Complex Complex)
+  (|>. (update@ #real r:negate)
+       (update@ #imaginary r:negate)))
+
+(def: #export signum
+  (-> Complex Complex)
+  (|>. (update@ #real r:signum)
+       (update@ #imaginary r:signum)))
+
+(def: #export conjugate
+  (-> Complex Complex)
+  (update@ #imaginary r:negate))
+
+(def: #export (c*' param input)
+  (-> Real Complex Complex)
+  {#real (*. param
+             (get@ #real input))
+   #imaginary (*. param
+                  (get@ #imaginary input))})
+
+(def: #export (c* param input)
+  (-> Complex Complex Complex)
+  {#real (-. (*. (get@ #imaginary param)
+                 (get@ #imaginary input))
+             (*. (get@ #real param)
+                 (get@ #real input)))
+   #imaginary (+. (*. (get@ #real param)
+                      (get@ #imaginary input))
+                  (*. (get@ #imaginary param)
+                      (get@ #real input)))})
+
+(def: #export (c/ (^slots [#real #imaginary]) input)
+  (-> Complex Complex Complex)
+  (if (<. (r:abs imaginary)
+          (r:abs real))
+    (let [quot (/. imaginary real)
+          denom (|> real (*. quot) (+. imaginary))]
+      {#real (|> (get@ #real input) (*. quot) (+. (get@ #imaginary input)) (/. denom))
+       #imaginary (|> (get@ #imaginary input) (*. quot) (-. (get@ #real input)) (/. denom))})
+    (let [quot (/. real imaginary)
+          denom (|> imaginary (*. quot) (+. real))]
+      {#real (|> (get@ #imaginary input) (*. quot) (+. (get@ #real input)) (/. denom))
+       #imaginary (|> (get@ #imaginary input) (-. (*. quot (get@ #real input))) (/. denom))})))
+
+(def: #export (c/' param (^slots [#real #imaginary]))
+  (-> Real Complex Complex)
+  {#real (/. param real)
+   #imaginary (/. param imaginary)})
+
+(def: #export (cos (^slots [#real #imaginary]))
+  (-> Complex Complex)
+  {#real (*. (math;cosh imaginary)
+             (math;cos real))
+   #imaginary (*. (math;sinh imaginary)
+                  (r:negate (math;sin real)))})
+
+(def: #export (cosh (^slots [#real #imaginary]))
+  (-> Complex Complex)
+  {#real (*. (math;cos imaginary)
+             (math;cosh real))
+   #imaginary (*. (math;sin imaginary)
+                  (math;sinh real))})
+
+(def: #export (sin (^slots [#real #imaginary]))
+  (-> Complex Complex)
+  {#real (*. (math;cosh imaginary)
+             (math;sin real))
+   #imaginary (*. (math;sinh imaginary)
+                  (math;cos real))})
+
+(def: #export (sinh (^slots [#real #imaginary]))
+  (-> Complex Complex)
+  {#real (*. (math;cos imaginary)
+             (math;sinh real))
+   #imaginary (*. (math;sin imaginary)
+                  (math;cosh real))})
+
+(def: #export (tan (^slots [#real #imaginary]))
+  (-> Complex Complex)
+  (let [r2 (*. 2.0 real)
+        i2 (*. 2.0 imaginary)
+        d (+. (math;cos r2) (math;cosh i2))]
+    {#real (/. d (math;sin r2))
+     #imaginary (/. d (math;sinh i2))}))
+
+(def: #export (tanh (^slots [#real #imaginary]))
+  (-> Complex Complex)
+  (let [r2 (*. 2.0 real)
+        i2 (*. 2.0 imaginary)
+        d (+. (math;cosh r2) (math;cos i2))]
+    {#real (/. d (math;sinh r2))
+     #imaginary (/. d (math;sin i2))}))
+
+(def: #export (abs (^slots [#real #imaginary]))
+  (-> Complex Real)
+  (if (<. (r:abs imaginary)
+          (r:abs real))
+    (if (=. 0.0 imaginary)
+      (r:abs real)
+      (let [q (/. imaginary real)]
+        (*. (math;sqrt (+. 1.0 (*. q q)))
+            (r:abs imaginary))))
+    (if (=. 0.0 real)
+      (r:abs imaginary)
+      (let [q (/. real imaginary)]
+        (*. (math;sqrt (+. 1.0 (*. q q)))
+            (r:abs real))))
+    ))
+
+(def: #export (exp (^slots [#real #imaginary]))
+  (-> Complex Complex)
+  (let [r-exp (math;exp real)]
+    {#real (*. r-exp (math;cos imaginary))
+     #imaginary (*. r-exp (math;sin imaginary))}))
+
+(def: #export (log (^@ input (^slots [#real #imaginary])))
+  (-> Complex Complex)
+  {#real (math;log (abs input))
+   #imaginary (math;atan2 real imaginary)})
+
+(do-template [  ]
+  [(def: #export ( param input)
+     (->  Complex Complex)
+     (|> input log ( param) exp))]
+
+  [pow  Complex c*]
+  [pow' Real    c*']
+  )
+
+(def: (copy-sign sign magnitude)
+  (-> Real Real Real)
+  (*. (r:signum sign) magnitude))
+
+(def: #export (sqrt (^@ input (^slots [#real #imaginary])))
+  (-> Complex Complex)
+  (let [t (|> input abs (+. (r:abs real)) (/. 2.0) math;sqrt)]
+    (if (>=. 0.0 real)
+      {#real t
+       #imaginary (/. (*. 2.0 t)
+                      imaginary)}
+      {#real (/. (*. 2.0 t)
+                 (r:abs imaginary))
+       #imaginary (*. t (copy-sign imaginary 1.0))})))
+
+(def: #export (sqrt-1z input)
+  (-> Complex Complex)
+  (|> (complex 1.0) (c- (c* input input)) sqrt))
+
+(def: #export (reciprocal (^slots [#real #imaginary]))
+  (-> Complex Complex)
+  (if (<. (r:abs imaginary)
+          (r:abs real))
+    (let [q (/. imaginary real)
+          scale (/. (|> real (*. q) (+. imaginary))
+                    1.0)]
+      {#real (*. q scale)
+       #imaginary (r:negate scale)})
+    (let [q (/. real imaginary)
+          scale (/. (|> imaginary (*. q) (+. real))
+                    1.0)]
+      {#real scale
+       #imaginary (|> scale r:negate (*. q))})))
+
+(def: #export (acos input)
+  (-> Complex Complex)
+  (|> input
+      (c+ (|> input sqrt-1z (c* i)))
+      log
+      (c* (negate i))))
+
+(def: #export (asin input)
+  (-> Complex Complex)
+  (|> input
+      sqrt-1z
+      (c+ (c* i input))
+      log
+      (c* (negate i))))
+
+(def: #export (atan input)
+  (-> Complex Complex)
+  (|> input
+      (c+ i)
+      (c/ (c- input i))
+      log
+      (c* (c/ (complex 2.0) i))))
+
+(def: #export (argument (^slots [#real #imaginary]))
+  (-> Complex Real)
+  (math;atan2 real imaginary))
+
+(def: #export (nth-root nth input)
+  (-> Nat Complex (List Complex))
+  (if (=+ +0 nth)
+    (list)
+    (let [r-nth (|> nth nat-to-int int-to-real)
+          nth-root-of-abs (math;pow (/. r-nth 1.0)
+                                    (abs input))
+          nth-phi (|> input argument (/. r-nth))
+          slice (|> math;pi (*. 2.0) (/. r-nth))]
+      (|> (list;range+ +0 (dec+ nth))
+          (List/map (lambda [nth']
+                      (let [inner (|> nth' nat-to-int int-to-real
+                                      (*. slice)
+                                      (+. nth-phi))
+                            real (*. nth-root-of-abs
+                                     (math;cos inner))
+                            imaginary (*. nth-root-of-abs
+                                          (math;sin inner))]
+                        {#real real
+                         #imaginary imaginary})))))))
+
+(struct: #export _ (Codec Text Complex)
+  (def: (encode (^slots [#real #imaginary]))
+    ($_ Text/append "(" (r:encode real) ", " (r:encode imaginary) ")"))
+
+  (def: (decode input)
+    (case (do Monad
+            [input' (text;sub +1 (-+ +1 (text;size input)) input)]
+            (text;split-with "," input'))
+      #;None
+      (#;Left (Text/append "Wrong syntax for complex numbers: " input))
+
+      (#;Some [r' i'])
+      (do Monad
+        [r (r:decode (text;trim r'))
+         i (r:decode (text;trim i'))]
+        (wrap {#real r
+               #imaginary i}))
+      )))
diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux
new file mode 100644
index 000000000..aee5674ad
--- /dev/null
+++ b/stdlib/source/lux/math/random.lux
@@ -0,0 +1,283 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  [lux #- list]
+  (lux (control functor
+                applicative
+                monad
+                hash)
+       (data [bit]
+             [char]
+             [text "Text/" Monoid]
+             text/format
+             [product]
+             [number]
+             (struct [list "List/" Fold]
+                     ["A" array]
+                     ["D" dict]
+                     ["Q" queue]
+                     ["S" set]
+                     ["ST" stack]
+                     ["V" vector]))
+       (math ["r" ratio]
+             ["c" complex])))
+
+## [Exports]
+(type: #export #rec PRNG
+  (-> Unit [PRNG Nat]))
+
+(type: #export (Random a)
+  (-> PRNG [PRNG a]))
+
+(struct: #export _ (Functor Random)
+  (def: (map f fa)
+    (lambda [state]
+      (let [[state' a] (fa state)]
+        [state' (f a)]))))
+
+(struct: #export _ (Applicative Random)
+  (def: functor Functor)
+
+  (def: (wrap a)
+    (lambda [state]
+      [state a]))
+
+  (def: (apply ff fa)
+    (lambda [state]
+      (let [[state' f] (ff state)
+            [state'' a] (fa state')]
+        [state'' (f a)]))))
+
+(struct: #export _ (Monad Random)
+  (def: applicative Applicative)
+
+  (def: (join ffa)
+    (lambda [state]
+      (let [[state' fa] (ffa state)]
+        (fa state')))))
+
+(def: #export nat
+  (Random Nat)
+  (lambda [prng]
+    (let [[prng left] (prng [])
+          [prng right] (prng [])]
+      [prng (++ (bit;<< +32 left)
+                right)])))
+
+(def: #export int
+  (Random Int)
+  (lambda [prng]
+    (let [[prng left] (prng [])
+          [prng right] (prng [])]
+      [prng (nat-to-int (++ (bit;<< +32 left)
+                            right))])))
+
+(def: #export bool
+  (Random Bool)
+  (lambda [prng]
+    (let [[prng output] (prng [])]
+      [prng (|> output (bit;& +1) (=+ +1))])))
+
+(def: (bits n)
+  (-> Nat (Random Nat))
+  (lambda [prng]
+    (let [[prng output] (prng [])]
+      [prng (bit;>>> (-+ n +64) output)])))
+
+(def: #export real
+  (Random Real)
+  (do Monad
+    [left (bits +26)
+     right (bits +27)]
+    (wrap (|> right
+              (++ (bit;<< +27 left))
+              nat-to-int
+              int-to-real
+              (/. (|> +1 (bit;<< +53) nat-to-int int-to-real))))))
+
+(def: #export frac
+  (Random Frac)
+  (:: Monad map real-to-frac real))
+
+(def: #export char
+  (Random Char)
+  (do Monad
+    [base nat]
+    (wrap (char;char base))))
+
+(def: #export (text' char-gen size)
+  (-> (Random Char) Nat (Random Text))
+  (if (=+ +0 size)
+    (:: Monad wrap "")
+    (do Monad
+      [x char-gen
+       xs (text' char-gen (dec+ size))]
+      (wrap (Text/append (char;as-text x) xs)))))
+
+(def: #export (text size)
+  (-> Nat (Random Text))
+  (text' char size))
+
+(do-template [   ]
+  [(def: #export 
+     (Random )
+     (do Monad
+       [left 
+        right ]
+       (wrap ( left right))))]
+
+  [ratio   r;Ratio   r;ratio   int]
+  [complex c;Complex c;complex real]
+  )
+
+(def: #export (seq left right)
+  (All [a b] (-> (Random a) (Random b) (Random [a b])))
+  (do Monad
+    [=left left
+     =right right]
+    (wrap [=left =right])))
+
+(def: #export (alt left right)
+  (All [a b] (-> (Random a) (Random b) (Random (| a b))))
+  (do Monad
+    [? bool]
+    (if ?
+      (do @
+        [=left left]
+        (wrap (+0 =left)))
+      (do @
+        [=right right]
+        (wrap (+1 =right))))))
+
+(def: #export (either left right)
+  (All [a] (-> (Random a) (Random a) (Random a)))
+  (do Monad
+    [? bool]
+    (if ?
+      left
+      right)))
+
+(def: #export (rec gen)
+  (All [a] (-> (-> (Random a) (Random a)) (Random a)))
+  (lambda [state]
+    (let [gen' (gen (rec gen))]
+      (gen' state))))
+
+(def: #export (filter pred gen)
+  (All [a] (-> (-> a Bool) (Random a) (Random a)))
+  (do Monad
+    [sample gen]
+    (if (pred sample)
+      (wrap sample)
+      (filter pred gen))))
+
+(do-template [   ]
+  [(def: #export ( size value-gen)
+     (All [a] (-> Nat (Random a) (Random ( a))))
+     (if (>+ +0 size)
+       (do Monad
+         [x value-gen
+          xs ( (dec+ size) value-gen)]
+         (wrap ( x xs)))
+       (:: Monad wrap )))]
+
+  [list   List    (;list)  #;Cons]
+  [vector V;Vector V;empty V;add]
+  )
+
+(do-template [  ]
+  [(def: #export ( size value-gen)
+     (All [a] (-> Nat (Random a) (Random ( a))))
+     (do Monad
+       [values (list size value-gen)]
+       (wrap (|> values ))))]
+
+  [array A;Array  A;from-list]
+  [queue Q;Queue  Q;from-list]
+  [stack ST;Stack (List/fold ST;push ST;empty)]
+  )
+
+(def: #export (set a/Hash size value-gen)
+  (All [a] (-> (Hash a) Nat (Random a) (Random (S;Set a))))
+  (if (>+ +0 size)
+    (do Monad
+      [xs (set a/Hash (dec+ size) value-gen)]
+      (loop [_ []]
+        (do @
+          [x value-gen
+           #let [xs+ (S;add x xs)]]
+          (if (=+ size (S;size xs+))
+            (wrap xs+)
+            (recur [])))))
+    (:: Monad wrap (S;new a/Hash))))
+
+(def: #export (dict a/Hash size key-gen value-gen)
+  (All [k v] (-> (Hash k) Nat (Random k) (Random v) (Random (D;Dict k v))))
+  (if (>+ +0 size)
+    (do Monad
+      [kv (dict a/Hash (dec+ size) key-gen value-gen)]
+      (loop [_ []]
+        (do @
+          [k key-gen
+           v value-gen
+           #let [kv+ (D;put k v kv)]]
+          (if (=+ size (D;size kv+))
+            (wrap kv+)
+            (recur [])))))
+    (:: Monad wrap (D;new a/Hash))))
+
+(def: #export (run prng calc)
+  (All [a] (-> PRNG (Random a) [PRNG a]))
+  (calc prng))
+
+## [PRNGs]
+## PCG32 http://www.pcg-random.org/
+## Based on this Java implementation: https://github.com/alexeyr/pcg-java
+
+(def: pcg-32-magic-mult Nat +6364136223846793005)
+
+(def: #export (pcg-32 [inc seed])
+  (-> [Nat Nat] PRNG)
+  (lambda [_]
+    (let [seed' (|> seed (*+ pcg-32-magic-mult) (++ inc))
+          xor-shifted (|> seed (bit;>>> +18) (bit;^ seed) (bit;>>> +27))
+          rot (|> seed (bit;>>> +59))]
+      [(pcg-32 [inc seed']) (bit;rotate-right rot xor-shifted)]
+      )))
+
+## Xoroshiro128+ http://xoroshiro.di.unimi.it/
+(def: #export (xoroshiro-128+ [s0 s1])
+  (-> [Nat Nat] PRNG)
+  (lambda [_]
+    (let [result (++ s0 s1)
+          s01 (bit;^ s0 s1)
+          s0' (|> (bit;rotate-left +55 s0)
+                  (bit;^ s01)
+                  (bit;^ (bit;<< +14 s01)))
+          s1' (bit;rotate-left +36 s01)]
+      [(xoroshiro-128+ [s0' s1']) result])
+    ))
+
+## [Values]
+(def: (swap from to vec)
+  (All [a] (-> Nat Nat (V;Vector a) (V;Vector a)))
+  (V;put to (default (undefined)
+              (V;at from vec))
+         vec))
+
+(def: #export (shuffle seed vector)
+  (All [a] (-> Nat (V;Vector a) (V;Vector a)))
+  (let [_size (V;size vector)
+        _shuffle (foldM Monad
+                        (lambda [idx vec]
+                          (do Monad
+                            [rand nat]
+                            (wrap (swap idx (%+ _size rand) vec))))
+                        vector
+                        (list;range+ +0 (dec+ _size)))]
+    (|> _shuffle
+        (run (pcg-32 [+123 seed]))
+        product;right)))
diff --git a/stdlib/source/lux/math/ratio.lux b/stdlib/source/lux/math/ratio.lux
new file mode 100644
index 000000000..89d93aa5d
--- /dev/null
+++ b/stdlib/source/lux/math/ratio.lux
@@ -0,0 +1,141 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux [math]
+       (control eq
+                [ord]
+                number
+                codec
+                monad)
+       (data [number "i:" Number Codec]
+             [text "Text/" Monoid]
+             error)
+       [compiler]
+       (macro [ast]
+              ["s" syntax #+ syntax: Syntax])))
+
+(type: #export Ratio
+  {#numerator Int
+   #denominator Int})
+
+(def: #hidden (normalize (^slots [#numerator #denominator]))
+  (-> Ratio Ratio)
+  (let [common (math;gcd numerator denominator)
+        numerator (/ common numerator)
+        denominator (/ common denominator)]
+    {#numerator (if (and (< 0 numerator)
+                         (< 0 denominator))
+                  (i:abs numerator)
+                  numerator)
+     #denominator (i:abs denominator)}))
+
+(def: #export (r* param input)
+  (-> Ratio Ratio Ratio)
+  (normalize [(* (get@ #numerator param)
+                 (get@ #numerator input))
+              (* (get@ #denominator param)
+                 (get@ #denominator input))]))
+
+(def: #export (r/ param input)
+  (-> Ratio Ratio Ratio)
+  (normalize [(* (get@ #denominator param)
+                 (get@ #numerator input))
+              (* (get@ #numerator param)
+                 (get@ #denominator input))]))
+
+(def: #export (r+ param input)
+  (-> Ratio Ratio Ratio)
+  (normalize [(+ (* (get@ #denominator input)
+                    (get@ #numerator param))
+                 (* (get@ #denominator param)
+                    (get@ #numerator input)))
+              (* (get@ #denominator param)
+                 (get@ #denominator input))]))
+
+(def: #export (r- param input)
+  (-> Ratio Ratio Ratio)
+  (normalize [(- (* (get@ #denominator input)
+                    (get@ #numerator param))
+                 (* (get@ #denominator param)
+                    (get@ #numerator input)))
+              (* (get@ #denominator param)
+                 (get@ #denominator input))]))
+
+(def: #export (r% param input)
+  (-> Ratio Ratio Ratio)
+  (let [quot (/ (* (get@ #denominator input)
+                   (get@ #numerator param))
+                (* (get@ #denominator param)
+                   (get@ #numerator input)))]
+    (r- (update@ #numerator (* quot) param)
+        input)))
+
+(def: #export (r= param input)
+  (-> Ratio Ratio Bool)
+  (and (= (get@ #numerator param)
+          (get@ #numerator input))
+       (= (get@ #denominator param)
+          (get@ #denominator input))))
+
+(do-template [ ]
+  [(def: #export ( param input)
+     (-> Ratio Ratio Bool)
+     (and ( (* (get@ #denominator input)
+                   (get@ #numerator param))
+                (* (get@ #denominator param)
+                   (get@ #numerator input)))))]
+
+  [r<  <]
+  [r<= <=]
+  [r>  >]
+  [r>= >=]
+  )
+
+(struct: #export _ (Eq Ratio)
+  (def: = r=))
+
+(struct: #export _ (ord;Ord Ratio)
+  (def: eq Eq)
+  (def: < r<)
+  (def: <= r<=)
+  (def: > r>)
+  (def: >= r>=))
+
+(struct: #export _ (Number Ratio)
+  (def: ord Ord)
+  (def: + r+)
+  (def: - r-)
+  (def: * r*)
+  (def: / r/)
+  (def: % r%)
+  (def: negate (|>. (update@ #numerator i:negate) normalize))
+  (def: abs (|>. (update@ #numerator i:abs) (update@ #denominator i:abs)))
+  (def: (signum x)
+    {#numerator (i:signum (get@ #numerator x))
+     #denominator 1}))
+
+(def: separator Text ":")
+
+(struct: #export _ (Codec Text Ratio)
+  (def: (encode (^slots [#numerator #denominator]))
+    ($_ Text/append (i:encode numerator) separator (i:encode denominator)))
+
+  (def: (decode input)
+    (case (text;split-with separator input)
+      (#;Some [num denom])
+      (do Monad
+        [numerator (i:decode num)
+         denominator (i:decode denom)]
+        (wrap (normalize {#numerator numerator
+                          #denominator denominator})))
+      
+      #;None
+      (#;Left (Text/append "Invalid syntax for ratio: " input)))))
+
+(syntax: #export (ratio numerator denominator)
+  (wrap (list (` (normalize {#;;numerator (~ numerator)
+                             #;;denominator (~ denominator)})))))
diff --git a/stdlib/source/lux/pipe.lux b/stdlib/source/lux/pipe.lux
new file mode 100644
index 000000000..b1316f238
--- /dev/null
+++ b/stdlib/source/lux/pipe.lux
@@ -0,0 +1,147 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module: {#;doc "Composable extensions to the piping macro |> that enhance it with various abilities."}
+  lux
+  (lux (control monad)
+       (data (struct [list #+ Monad "" Fold "List/" Monad])
+             maybe)
+       [compiler #+ with-gensyms Monad]
+       (macro ["s" syntax #+ syntax: Syntax]
+              [ast])
+       ))
+
+## [Syntax]
+(def: body^
+  (Syntax (List AST))
+  (s;tuple (s;many s;any)))
+
+(syntax: #export (_> {tokens (s;at-least +2 s;any)})
+  {#;doc (doc "Ignores the piped argument, and begins a new pipe."
+              (|> 20
+                  (* 3)
+                  (+ 4)
+                  (_> 0 inc)))}
+  (case (list;reverse tokens)
+    (^ (list& _ r-body))
+    (wrap (list (` (|> (~@ (list;reverse r-body))))))
+
+    _
+    (undefined)))
+
+(syntax: #export (@> {body body^}
+                     prev)
+  {#;doc (doc "Gives the name '@' to the piped-argument, within the given expression."
+              (|> 5
+                  (@> [(+ @ @)])))}
+  (wrap (list (fold (lambda [next prev]
+                      (` (let% [(~' @) (~ prev)]
+                           (~ next))))
+                    prev
+                    body))))
+
+(syntax: #export (?> {branches (s;many (s;seq body^ body^))}
+                     {?else (s;opt body^)}
+                     prev)
+  {#;doc (doc "Branching for pipes."
+              "Both the tests and the bodies are piped-code, and must be given inside a tuple."
+              "If a last else-pipe isn't given, the piped-argument will be used instead."
+              (|> 5
+                  (?> [even?] [(* 2)]
+                      [odd?] [(* 3)]
+                      [(_> -1)])))}
+  (with-gensyms [g!temp]
+    (wrap (list (` (let% [(~ g!temp) (~ prev)]
+                     (cond (~@ (do Monad
+                                 [[test then] branches]
+                                 (list (` (|> (~ g!temp) (~@ test)))
+                                       (` (|> (~ g!temp) (~@ then))))))
+                           (~ (case ?else
+                                (#;Some else)
+                                (` (|> (~ g!temp) (~@ else)))
+
+                                _
+                                g!temp)))))))))
+
+(syntax: #export (!> {test body^} {then body^} prev)
+  {#;doc (doc
+          "Loops for pipes."
+          "Both the testing and calculating steps are pipes and must be given inside tuples."
+          (|> 1
+              (!> [(< 10)]
+                  [inc])))}
+  (with-gensyms [g!temp]
+    (wrap (list (` (loop [(~ g!temp) (~ prev)]
+                     (if (|> (~ g!temp) (~@ test))
+                       ((~' recur) (|> (~ g!temp) (~@ then)))
+                       (~ g!temp))))))))
+
+(syntax: #export (%> monad {steps (s;some body^)} prev)
+  {#;doc (doc "Monadic pipes."
+              "Each steps in the monadic computation is a pipe and must be given inside a tuple."
+              (|> 5
+                  (%> Id/Monad
+                      [(* 3)]
+                      [(+ 4)]
+                      [inc])))}
+  (with-gensyms [g!temp]
+    (case (list;reverse steps)
+      (^ (list& last-step prev-steps))
+      (let [step-bindings (do Monad
+                            [step (list;reverse prev-steps)]
+                            (list g!temp (` (|> (~ g!temp) (~@ step)))))]
+        (wrap (list (` (do (~ monad)
+                         [(~ g!temp) (~ prev)
+                          (~@ step-bindings)]
+                         (|> (~ g!temp) (~@ last-step)))))))
+
+      _
+      (wrap (list prev)))))
+
+(syntax: #export (~> {body body^} prev)
+  {#;doc (doc "Non-updating pipes."
+              "Will generate piped computations, but their results won't be used in the larger scope."
+              (|> 5
+                  (~> [int-to-nat %n log!])
+                  (* 10)))}
+  (do @
+    [g!temp (compiler;gensym "")]
+    (wrap (list (` (let [(~ g!temp) (~ prev)]
+                     (exec (|> (~ g!temp) (~@ body))
+                       (~ g!temp))))))))
+
+(syntax: #export (&> {paths (s;many body^)} prev)
+  {#;doc (doc "Parallel branching for pipes."
+              "Allows to run multiple pipelines for a value and gives you a tuple of the outputs."
+              (|> 5
+                  (&> [(* 10)]
+                      [dec (/ 2)]
+                      [Int/encode]))
+              "Will become: [50 2 \"5\"]")}
+  (do @
+    [g!temp (compiler;gensym "")]
+    (wrap (list (` (let [(~ g!temp) (~ prev)]
+                     [(~@ (List/map (lambda [body] (` (|> (~ g!temp) (~@ body))))
+                                    paths))]))))))
+
+(syntax: #export (case> {branches (s;many (s;seq s;any s;any))} prev)
+  {#;doc (doc "Pattern-matching for pipes."
+              "The bodies of each branch are NOT pipes; just regular values."
+              (|> 5
+                  (case> 0 "zero"
+                         1 "one"
+                         2 "two"
+                         3 "three"
+                         4 "four"
+                         5 "five"
+                         6 "six"
+                         7 "seven"
+                         8 "eight"
+                         9 "nine"
+                         _ "???")))}
+  (let [(^open "List/") Monad]
+    (wrap (list (` (case (~ prev)
+                     (~@ (List/join (List/map (lambda [[pattern body]] (list pattern body))
+                                              branches)))))))))
diff --git a/stdlib/source/lux/regex.lux b/stdlib/source/lux/regex.lux
new file mode 100644
index 000000000..1d98d6bf5
--- /dev/null
+++ b/stdlib/source/lux/regex.lux
@@ -0,0 +1,432 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monad)
+       (data [char]
+             [text]
+             text/format
+             [number "Int/" Codec]
+             [product]
+             (struct [list "" Fold "List/" Monad]))
+       [compiler #- run]
+       (macro [ast]
+              [syntax #+ syntax:])
+       ["&" lexer #+ Lexer Monad]))
+
+## [Utils]
+(def: #hidden (->Text lexer^)
+  (-> (Lexer Char) (Lexer Text))
+  (do Monad
+    [output lexer^]
+    (wrap (char;as-text output))))
+
+(def: regex-char^
+  (Lexer Char)
+  (&;none-of "\\.|&()[]{}"))
+
+(def: escaped-char^
+  (Lexer Char)
+  (do Monad
+    [? (&;opt (&;this-char #"\\"))
+     char (case ?
+            (#;Some _) &;any
+            #;None     regex-char^)]
+    (wrap char)))
+
+(def: (local^ state lexer)
+  (All [a] (-> Text (Lexer a) (Lexer a)))
+  (lambda [old-state]
+    (case (lexer state)
+      (#;Left error)
+      (#;Left error)
+
+      (#;Right [_ value])
+      (#;Right [old-state value]))))
+
+(def: #hidden (refine^ refinement^ base^)
+  (All [a] (-> (Lexer a) (Lexer Text) (Lexer Text)))
+  (do Monad
+    [output base^
+     _ (local^ output refinement^)]
+    (wrap output)))
+
+(def: #hidden word^
+  (Lexer Char)
+  (&;either &;alpha-num
+            (&;this-char #"_")))
+
+(def: #hidden (join-text^ part^)
+  (-> (Lexer (List Text)) (Lexer Text))
+  (do Monad
+    [parts part^]
+    (wrap (text;join-with "" parts))))
+
+(def: identifier-char^
+  (Lexer Char)
+  (&;none-of "[]{}()s\"#;<>"))
+
+(def: identifier-part^
+  (Lexer Text)
+  (do Monad
+    [head (refine^ (&;not &;digit)
+                   (->Text identifier-char^))
+     tail (&;some' identifier-char^)]
+    (wrap (format head tail))))
+
+(def: (identifier^ current-module)
+  (-> Text (Lexer Ident))
+  (do Monad
+    []
+    ($_ &;either
+        (&;seq (wrap current-module) (&;_& (&;this ";;") identifier-part^))
+        (&;seq identifier-part^ (&;_& (&;this ";") identifier-part^))
+        (&;seq (wrap "lux") (&;_& (&;this ";") identifier-part^))
+        (&;seq (wrap "") identifier-part^))))
+
+(def: (re-var^ current-module)
+  (-> Text (Lexer AST))
+  (do Monad
+    [ident (&;enclosed ["\\@<" ">"] (identifier^ current-module))]
+    (wrap (` (: (Lexer Text) (~ (ast;symbol ident)))))))
+
+(def: re-char-range^
+  (Lexer AST)
+  (do Monad
+    [from regex-char^
+     _ (&;this-char #"-")
+     to regex-char^]
+    (wrap (` (&;char-range (~ (ast;char from)) (~ (ast;char to)))))))
+
+(def: re-char^
+  (Lexer AST)
+  (do Monad
+    [char escaped-char^]
+    (wrap (` (&;this-char (~ (ast;char char)))))))
+
+(def: re-char+^
+  (Lexer AST)
+  (do Monad
+    [base re-char^]
+    (wrap (` (->Text (~ base))))))
+
+(def: re-char-options^
+  (Lexer AST)
+  (do Monad
+    [options (&;many' escaped-char^)]
+    (wrap (` (&;one-of (~ (ast;text options)))))))
+
+(def: re-user-class^'
+  (Lexer AST)
+  (do Monad
+    [negate? (&;opt (&;this-char #"^"))
+     parts (&;many ($_ &;either
+                       re-char-range^
+                       re-char-options^))]
+    (wrap (case negate?
+            (#;Some _) (` (->Text (&;not ($_ &;either (~@ parts)))))
+            #;None     (` (->Text ($_ &;either (~@ parts))))))))
+
+(def: re-user-class^
+  (Lexer AST)
+  (do Monad
+    [_ (wrap [])
+     init re-user-class^'
+     rest (&;some (&;_& (&;this "&&") (&;enclosed ["[" "]"] re-user-class^')))]
+    (wrap (fold (lambda [refinement base]
+                  (` (refine^ (~ refinement) (~ base))))
+                init
+                rest))))
+
+(def: #hidden blank^
+  (Lexer Char)
+  (&;one-of " \t"))
+
+(def: #hidden ascii^
+  (Lexer Char)
+  (&;char-range #"\u0000" #"\u007F"))
+
+(def: #hidden control^
+  (Lexer Char)
+  (&;either (&;char-range #"\u0000" #"\u001F")
+            (&;this-char #"\u007F")))
+
+(def: #hidden punct^
+  (Lexer Char)
+  (&;one-of "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~"))
+
+(def: #hidden graph^
+  (Lexer Char)
+  (&;either punct^ &;alpha-num))
+
+(def: #hidden print^
+  (Lexer Char)
+  (&;either graph^
+            (&;this-char #"\u0020")))
+
+(def: re-system-class^
+  (Lexer AST)
+  (do Monad
+    []
+    ($_ &;either
+        (&;_& (&;this-char #".") (wrap (` (->Text &;any))))
+        (&;_& (&;this "\\d") (wrap (` (->Text &;digit))))
+        (&;_& (&;this "\\D") (wrap (` (->Text (&;not &;digit)))))
+        (&;_& (&;this "\\s") (wrap (` (->Text  &;space))))
+        (&;_& (&;this "\\S") (wrap (` (->Text (&;not &;space)))))
+        (&;_& (&;this "\\w") (wrap (` (->Text word^))))
+        (&;_& (&;this "\\W") (wrap (` (->Text (&;not word^)))))
+        (&;_& (&;this "\\d") (wrap (` (->Text &;digit))))
+
+        (&;_& (&;this "\\p{Lower}") (wrap (` (->Text &;lower))))
+        (&;_& (&;this "\\p{Upper}") (wrap (` (->Text &;upper))))
+        (&;_& (&;this "\\p{Alpha}") (wrap (` (->Text &;alpha))))
+        (&;_& (&;this "\\p{Digit}") (wrap (` (->Text &;digit))))
+        (&;_& (&;this "\\p{Alnum}") (wrap (` (->Text &;alpha-num))))
+        (&;_& (&;this "\\p{Space}") (wrap (` (->Text &;space))))
+        (&;_& (&;this "\\p{HexDigit}") (wrap (` (->Text &;hex-digit))))
+        (&;_& (&;this "\\p{OctDigit}") (wrap (` (->Text &;oct-digit))))
+        (&;_& (&;this "\\p{Blank}") (wrap (` (->Text blank^))))
+        (&;_& (&;this "\\p{ASCII}") (wrap (` (->Text ascii^))))
+        (&;_& (&;this "\\p{Contrl}") (wrap (` (->Text control^))))
+        (&;_& (&;this "\\p{Punct}") (wrap (` (->Text punct^))))
+        (&;_& (&;this "\\p{Graph}") (wrap (` (->Text graph^))))
+        (&;_& (&;this "\\p{Print}") (wrap (` (->Text print^))))
+        )))
+
+(def: re-class^
+  (Lexer AST)
+  (&;either re-system-class^
+            (&;enclosed ["[" "]"] re-user-class^)))
+
+(def: int^
+  (Lexer Int)
+  (&;codec number;Codec (&;many' &;digit)))
+
+(def: re-back-reference^
+  (Lexer AST)
+  (&;either (do Monad
+              [_ (&;this-char #"\\")
+               id int^]
+              (wrap (` (&;this (~ (ast;symbol ["" (Int/encode id)]))))))
+            (do Monad
+              [_ (&;this "\\k<")
+               captured-name identifier-part^
+               _ (&;this ">")]
+              (wrap (` (&;this (~ (ast;symbol ["" captured-name]))))))))
+
+(def: (re-simple^ current-module)
+  (-> Text (Lexer AST))
+  ($_ &;either
+      re-class^
+      (re-var^ current-module)
+      re-back-reference^
+      re-char+^
+      ))
+
+(def: (re-simple-quantified^ current-module)
+  (-> Text (Lexer AST))
+  (do Monad
+    [base (re-simple^ current-module)
+     quantifier (&;one-of "?*+")]
+    (case quantifier
+      #"?"
+      (wrap (` (&;default "" (~ base))))
+      
+      #"*"
+      (wrap (` (join-text^ (&;some (~ base)))))
+      
+      _
+      (wrap (` (join-text^ (&;many (~ base)))))
+      )))
+
+(def: (re-counted-quantified^ current-module)
+  (-> Text (Lexer AST))
+  (do Monad
+    [base (re-simple^ current-module)]
+    (&;enclosed ["{" "}"]
+                ($_ &;either
+                    (do @
+                      [[from to] (&;seq int^ (&;_& (&;this-char #",") int^))]
+                      (wrap (` (join-text^ (&;between (~ (ast;nat (int-to-nat from)))
+                                                      (~ (ast;nat (int-to-nat to)))
+                                                      (~ base))))))
+                    (do @
+                      [limit (&;_& (&;this-char #",") int^)]
+                      (wrap (` (join-text^ (&;at-most (~ (ast;nat (int-to-nat limit))) (~ base))))))
+                    (do @
+                      [limit (&;&_ int^ (&;this-char #","))]
+                      (wrap (` (join-text^ (&;at-least (~ (ast;nat (int-to-nat limit))) (~ base))))))
+                    (do @
+                      [limit int^]
+                      (wrap (` (join-text^ (&;exactly (~ (ast;nat (int-to-nat limit))) (~ base))))))))))
+
+(def: (re-quantified^ current-module)
+  (-> Text (Lexer AST))
+  (&;either (re-simple-quantified^ current-module)
+            (re-counted-quantified^ current-module)))
+
+(def: (re-complex^ current-module)
+  (-> Text (Lexer AST))
+  ($_ &;either
+      (re-quantified^ current-module)
+      (re-simple^ current-module)))
+
+(def: #hidden _Text/append_
+  (-> Text Text Text)
+  (:: text;Monoid append))
+
+(type: Re-Group
+  #Non-Capturing
+  (#Capturing [(Maybe Text) Nat]))
+
+(def: (re-sequential^ capturing? re-scoped^ current-module)
+  (-> Bool
+      (-> Text (Lexer [Re-Group AST]))
+      Text
+      (Lexer [Nat AST]))
+  (do Monad
+    [parts (&;many (&;alt (re-complex^ current-module)
+                          (re-scoped^ current-module)))
+     #let [g!total (ast;symbol ["" "0total"])
+           g!temp (ast;symbol ["" "0temp"])
+           [_ names steps] (fold (: (-> (Either AST [Re-Group AST])
+                                        [Int (List AST) (List (List AST))]
+                                        [Int (List AST) (List (List AST))])
+                                    (lambda [part [idx names steps]]
+                                      (case part
+                                        (^or (#;Left complex) (#;Right [#Non-Capturing complex]))
+                                        [idx
+                                         names
+                                         (list& (list g!temp complex
+                                                      (' #let) (` [(~ g!total) (_Text/append_ (~ g!total) (~ g!temp))]))
+                                                steps)]
+                                        
+                                        (#;Right [(#Capturing [?name num-captures]) scoped])
+                                        (let [[idx! name!] (case ?name
+                                                             (#;Some _name)
+                                                             [idx (ast;symbol ["" _name])]
+
+                                                             #;None
+                                                             [(inc idx) (ast;symbol ["" (Int/encode idx)])])
+                                              access (if (>+ +0 num-captures)
+                                                       (` (product;left (~ name!)))
+                                                       name!)]
+                                          [idx!
+                                           (list& name! names)
+                                           (list& (list name! scoped
+                                                        (' #let) (` [(~ g!total) (_Text/append_ (~ g!total) (~ access))]))
+                                                  steps)])
+                                        )))
+                                 [0
+                                  (: (List AST) (list))
+                                  (: (List (List AST)) (list))]
+                                 parts)]]
+    (wrap [(if capturing?
+             (list;size names)
+             +0)
+           (` (do Monad
+                [(~ (' #let)) [(~ g!total) ""]
+                 (~@ (|> steps list;reverse List/join))]
+                ((~ (' wrap)) [(~ g!total) (~@ (list;reverse names))])))])
+    ))
+
+(def: #hidden (unflatten^ lexer)
+  (-> (Lexer Text) (Lexer [Text Unit]))
+  (&;seq lexer (:: Monad wrap [])))
+
+(def: #hidden (|||^ left right)
+  (All [l r] (-> (Lexer [Text l]) (Lexer [Text r]) (Lexer [Text (| l r)])))
+  (lambda [input]
+    (case (left input)
+      (#;Right [input' [lt lv]])
+      (#;Right [input' [lt (+0 lv)]])
+
+      (#;Left _)
+      (case (right input)
+        (#;Right [input' [rt rv]])
+        (#;Right [input' [rt (+1 rv)]])
+
+        (#;Left error)
+        (#;Left error)))))
+
+(def: #hidden (|||_^ left right)
+  (All [l r] (-> (Lexer [Text l]) (Lexer [Text r]) (Lexer Text)))
+  (lambda [input]
+    (case (left input)
+      (#;Right [input' [lt lv]])
+      (#;Right [input' lt])
+
+      (#;Left _)
+      (case (right input)
+        (#;Right [input' [rt rv]])
+        (#;Right [input' rt])
+
+        (#;Left error)
+        (#;Left error)))))
+
+(def: (prep-alternative [num-captures alt])
+  (-> [Nat AST] AST)
+  (if (>+ +0 num-captures)
+    alt
+    (` (unflatten^ (~ alt)))))
+
+(def: (re-alternative^ capturing? re-scoped^ current-module)
+  (-> Bool
+      (-> Text (Lexer [Re-Group AST]))
+      Text
+      (Lexer [Nat AST]))
+  (do Monad
+    [#let [sub^ (re-sequential^ capturing? re-scoped^ current-module)]
+     head sub^
+     tail (&;some (&;_& (&;this-char #"|") sub^))
+     #let [g!op (if capturing?
+                  (` |||^)
+                  (` |||_^))]]
+    (if (list;empty? tail)
+      (wrap head)
+      (wrap [(fold max+ (product;left head) (List/map product;left tail))
+             (` ($_ (~ g!op) (~ (prep-alternative head)) (~@ (List/map prep-alternative tail))))]))))
+
+(def: (re-scoped^ current-module)
+  (-> Text (Lexer [Re-Group AST]))
+  ($_ &;either
+      (do Monad
+        [_ (&;this "(?:")
+         [_ scoped] (re-alternative^ false re-scoped^ current-module)
+         _ (&;this-char #")")]
+        (wrap [#Non-Capturing scoped]))
+      (do Monad
+        [complex (re-complex^ current-module)]
+        (wrap [#Non-Capturing complex]))
+      (do Monad
+        [_ (&;this "(?<")
+         captured-name identifier-part^
+         _ (&;this ">")
+         [num-captures pattern] (re-alternative^ true re-scoped^ current-module)
+         _ (&;this-char #")")]
+        (wrap [(#Capturing [(#;Some captured-name) num-captures]) pattern]))
+      (do Monad
+        [_ (&;this-char #"(")
+         [num-captures pattern] (re-alternative^ true re-scoped^ current-module)
+         _ (&;this-char #")")]
+        (wrap [(#Capturing [#;None num-captures]) pattern]))))
+
+(def: (regex^ current-module)
+  (-> Text (Lexer AST))
+  (:: Monad map product;right (re-alternative^ true re-scoped^ current-module)))
+
+## [Syntax]
+(syntax: #export (regex {pattern syntax;text})
+  (do @
+    [current-module compiler;current-module-name]
+    (case (&;run (&;&_ (regex^ current-module) &;end) pattern)
+      (#;Left error)
+      (compiler;fail error)
+
+      (#;Right regex)
+      (wrap (list regex))
+      )))
diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux
new file mode 100644
index 000000000..eba8034f9
--- /dev/null
+++ b/stdlib/source/lux/test.lux
@@ -0,0 +1,330 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux [compiler #+ Monad with-gensyms]
+       (macro ["s" syntax #+ syntax: Syntax]
+              [ast])
+       (control functor
+                applicative
+                monad)
+       (concurrency [promise #* "Promise/" Monad])
+       (data (struct [list "List/" Monad])
+             [product]
+             [text]
+             text/format
+             [error #* "Error/" Monad])
+       (codata [io #- run])
+       (math ["R" random])
+       [host #- try]))
+
+## [Host]
+(jvm-import java.lang.System
+  (#static exit [int] #io void)
+  (#static currentTimeMillis [] #io long))
+
+(def: #hidden exit
+  (IO Unit)
+  (System.exit 0))
+
+## [Types]
+(type: #export (Test a)
+  (Promise (Error a)))
+
+## [Structs]
+(struct: #export _ (Functor Test)
+  (def: (map f fa)
+    (Promise/map (Error/map f) fa)))
+
+(struct: #export _ (Applicative Test)
+  (def: functor Functor)
+
+  (def: (wrap a)
+    (Promise/wrap (#;Right a)))
+
+  (def: (apply ff fa)
+    (do Monad
+      [f' ff
+       a' fa]
+      (case [f' a']
+        [(#;Right f) (#;Right a)]
+        (wrap (#;Right (f a)))
+
+        (^or [(#;Left msg) _] [_ (#;Left msg)])
+        (wrap (#;Left msg))))
+    ))
+
+(struct: #export _ (Monad Test)
+  (def: applicative Applicative)
+  
+  (def: (join mma)
+    (Promise/join (Promise/map (lambda [mma']
+                                 (case mma'
+                                   (#;Left msg)
+                                   (Promise/wrap (#;Left msg))
+
+                                   (#;Right ma)
+                                   ma))
+                               mma)))
+  )
+
+## [Values]
+(def: #export (fail message)
+  (All [a] (-> Text (Test a)))
+  (:: Monad wrap (#;Left message)))
+
+(def: #export (assert message test)
+  (-> Text Bool (Test Unit))
+  (if test
+    (:: Monad wrap [])
+    (fail message)))
+
+(def: #export (from-promise promise)
+  (All [a] (-> (Promise a) (Test a)))
+  (do Monad
+    [output promise]
+    (wrap (#;Right output))))
+
+(def: #hidden (run' tests)
+  (-> (List [Text (IO (Test Unit)) Text]) (Promise Unit))
+  (do Monad
+    [printings (mapM @
+                     (: (-> [Text (IO (Test Unit)) Text] (Promise Unit))
+                        (lambda [[module test description]]
+                          (do @
+                            [#let [pre (io;run (System.currentTimeMillis []))]
+                             outcome (io;run test)
+                             #let [post (io;run (System.currentTimeMillis []))]]
+                            (case outcome
+                              (#;Left error)
+                              (wrap (log! (format "Error: " (:: text;Codec encode description) " @ " module "\n" error "\n\n")))
+                              
+                              _
+                              (exec (log! (format "Success: " (:: text;Codec encode description) " @ " module
+                                                  " in " (%i (- pre post)) "ms"))
+                                (wrap []))))))
+                     tests)]
+    (wrap [])))
+
+(def: pcg-32-magic-inc Nat +12345)
+
+(type: #export Seed Nat)
+
+(def: #export (try seed random-test)
+  (-> Seed (R;Random (Test Unit)) (Test Seed))
+  (let [[prng [new-seed test]] (R;run (R;pcg-32 [pcg-32-magic-inc seed])
+                                      (do R;Monad
+                                        [test random-test
+                                         next-seed R;nat]
+                                        (wrap [next-seed test])))]
+    (do Monad
+      [_ test]
+      (wrap new-seed))))
+
+(def: (repeat' seed times random-test)
+  (-> Seed Nat (R;Random (Test Unit)) (Test Seed))
+  (case times
+    +0
+    (fail "Can't try a test 0 times.")
+    
+    +1
+    (try seed random-test)
+    
+    _
+    (do Monad
+      [output (try seed random-test)]
+      (case output
+        (#;Left error)
+        (fail (format "Test failed with this seed: " (%n seed) "\n" error))
+
+        (#;Right seed')
+        (repeat' seed' (dec+ times) random-test)))))
+
+(def: #export (repeat times random-test)
+  (-> Nat (R;Random (Test Unit)) (Test Unit))
+  (do Monad
+    [_ (repeat' (int-to-nat (io;run (System.currentTimeMillis [])))
+                times
+                random-test)]
+    (wrap [])))
+
+## [Syntax]
+(type: Property-Test
+  {#seed (Maybe (Either Nat Ident))
+   #bindings (List [AST AST])
+   #body AST})
+
+(type: Test-Kind
+  (#Property Property-Test)
+  (#Simple AST))
+
+(def: propery-test^
+  (Syntax Property-Test)
+  ($_ s;seq
+      (s;opt (s;alt s;nat
+                    s;symbol))
+      (s;tuple (s;some (s;seq s;any s;any)))
+      s;any))
+
+(def: test^
+  (Syntax Test-Kind)
+  (s;alt propery-test^
+         s;any))
+
+(def: (pair-to-list [x y])
+  (All [a] (-> [a a] (List a)))
+  (list x y))
+
+(syntax: #export (test: description {body test^})
+  {#;doc (doc "Macro for definint tests."
+              (test: "lux/pipe exports"
+                (all (match 1 (|> 20
+                                  (* 3)
+                                  (+ 4)
+                                  (_> 0 inc)))
+                     (match 10 (|> 5
+                                   (@> (+ @ @))))
+                     (match 15 (|> 5
+                                   (?> [even?] [(* 2)]
+                                       [odd?] [(* 3)]
+                                       [(_> -1)])))
+                     )))}
+  (let [body (case body
+               (#Property seed bindings body)
+               (let [seed' (case seed
+                             #;None
+                             (' +100)
+
+                             (#;Some (#;Left value))
+                             (ast;nat value)
+
+                             (#;Some (#;Right var))
+                             (ast;symbol var))
+                     bindings' (|> bindings (List/map pair-to-list) List/join)]
+                 (` (repeat (~ seed')
+                            (do R;Monad
+                              [(~@ bindings')]
+                              ((~' wrap) (~ body))))))
+               
+               (#Simple body)
+               body)]
+    (with-gensyms [g!test]
+      (wrap (list (` (def: #export (~ g!test)
+                       {#;;test (#;TextM (~ description))}
+                       (IO (Test Unit))
+                       (io (~ body)))))))))
+
+(def: (exported-tests module-name)
+  (-> Text (Lux (List [Text Text Text])))
+  (do Monad
+    [defs (compiler;exports module-name)]
+    (wrap (|> defs
+              (List/map (lambda [[def-name [_ def-anns _]]]
+                          (case (compiler;get-text-ann (ident-for #;;test) def-anns)
+                            (#;Some description)
+                            [true module-name def-name description]
+
+                            _
+                            [false module-name def-name ""])))
+              (list;filter product;left)
+              (List/map product;right)))))
+
+(syntax: #export (match pattern expression)
+  {#;doc (doc "Runs an expression and pattern-matches against it using the given pattern."
+              "If the pattern-matching succeeds, the test succeeds."
+              (match 15 (|> 5
+                            (?> [even?] [(* 2)]
+                                [odd?] [(* 3)]))))}
+  (with-gensyms [g!_]
+    (wrap (list (` (: (Test Unit)
+                      (case (~ expression)
+                        (~ pattern)
+                        (~' (:: Monad wrap []))
+
+                        (~ g!_)
+                        (fail (~ (ast;text (format "Pattern was not matched: " (ast;ast-to-text pattern)
+                                                   "\n\n" "From expression: " (ast;ast-to-text expression))))))))))))
+
+(def: #hidden (should-pass' veredict expr-repr)
+  (All [a] (-> (Error a) Text (Test a)))
+  (case veredict
+    (#;Left message) (fail (format "'" message "' @ " expr-repr))
+    (#;Right value)  (:: Monad wrap value)))
+
+(def: #hidden (should-fail' veredict expr-repr)
+  (All [a] (-> (Error a) Text (Test Unit)))
+  (case veredict
+    (#;Left message) (:: Monad wrap [])
+    (#;Right value)  (fail (format "Should have failed: " expr-repr))))
+
+(do-template [  ]
+  [(syntax: #export ( expr)
+     {#;doc }
+     (wrap (list (` ( (~ expr) (~ (ast;text (ast;ast-to-text expr))))))))]
+
+  [should-pass should-pass' "Verifies that a (Error a) computation succeeds/passes."]
+  [should-fail should-fail' "Verifies that a (Error a) computation fails."]
+  )
+
+(syntax: #export (match+ pattern source)
+  {#;doc (doc "Same as \"match\", but the expression/source is expected to be of type (Test a)."
+              "That is, it's asynchronous and it may fail."
+              "If, however, it succeeds, it's value will be pattern-matched against."
+              (match+ 5 (commit (do Monad
+                                  [_ (write 5 _var)
+                                   value (read _var)]
+                                  (wrap (#;Right value))))))}
+  (with-gensyms [g!temp]
+    (wrap (list (` (: (Test Unit)
+                      (do Monad
+                        [(~ g!temp) (~ source)]
+                        (match (~ pattern) (~ g!temp)))))))))
+
+(syntax: #export (run)
+  {#;doc (doc "Runs all the tests defined on the current module, and in all imported modules."
+              (run))}
+  (with-gensyms [g!_]
+    (do @
+      [current-module compiler;current-module-name
+       modules (compiler;imported-modules current-module)
+       tests (: (Lux (List [Text Text Text]))
+                (:: @ map List/join (mapM @ exported-tests (#;Cons current-module modules))))
+       #let [tests+ (List/map (lambda [[module-name test desc]]
+                                (` [(~ (ast;text module-name)) (~ (ast;symbol [module-name test])) (~ (ast;text desc))]))
+                              tests)
+             groups (list;split-all (|> (list;size tests+) (/+ concurrency-level) (++ +1) (min+ +16))
+                                    tests+)]]
+      (wrap (list (` (: (IO Unit)
+                        (io (exec (do Monad
+                                    [(~@ (List/join (List/map (lambda [group]
+                                                                (list g!_ (` (run' (list (~@ group))))))
+                                                              groups)))]
+                                    (exec (log! "Test-suite finished!")
+                                      (future exit)))
+                              [])))))))))
+
+(syntax: #export (all {tests (s;some s;any)})
+  {#;doc (doc "Given a sequence of tests, runs them all sequentially, and succeeds if the all succeed."
+              (test: "lux/pipe exports"
+                (all (match 1 (|> 20
+                                  (* 3)
+                                  (+ 4)
+                                  (_> 0 inc)))
+                     (match 10 (|> 5
+                                   (@> (+ @ @))))
+                     (match 15 (|> 5
+                                   (?> [even?] [(* 2)]
+                                       [odd?] [(* 3)]
+                                       [(_> -1)])))
+                     )))}
+  (with-gensyms [g!_]
+    (let [pairs (|> tests
+                    (List/map (: (-> AST (List AST)) (lambda [test] (list g!_ test))))
+                    List/join)]
+      (wrap (list (` (: (Test Unit)
+                        (do Monad
+                          [(~@ pairs)]
+                          ((~' wrap) [])))))))))
diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux
new file mode 100644
index 000000000..4a84582c4
--- /dev/null
+++ b/stdlib/source/lux/type.lux
@@ -0,0 +1,275 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control eq
+                monad)
+       (data [text "Text/" Monoid Eq]
+             [number "Nat/" Codec]
+             maybe
+             (struct [list #+ "List/" Monad Monoid Fold]))
+       (macro [ast])
+       ))
+
+## [Utils]
+(def: (beta-reduce env type)
+  (-> (List Type) Type Type)
+  (case type
+    (#;HostT name params)
+    (#;HostT name (List/map (beta-reduce env) params))
+    
+    (^template []
+     ( left right)
+     ( (beta-reduce env left) (beta-reduce env right)))
+    ([#;SumT] [#;ProdT])
+    
+    (^template []
+     ( left right)
+     ( (beta-reduce env left) (beta-reduce env right)))
+    ([#;LambdaT]
+     [#;AppT])
+
+    (^template []
+     ( old-env def)
+     (case old-env
+       #;Nil
+       ( env def)
+
+       _
+       type))
+    ([#;UnivQ]
+     [#;ExQ])
+    
+    (#;BoundT idx)
+    (default type (list;at idx env))
+    
+    (#;NamedT name type)
+    (beta-reduce env type)
+
+    _
+    type
+    ))
+
+## [Structures]
+(struct: #export _ (Eq Type)
+  (def: (= x y)
+    (case [x y]
+      [(#;HostT xname xparams) (#;HostT yname yparams)]
+      (and (Text/= xname yname)
+           (=+ (list;size yparams) (list;size xparams))
+           (List/fold (lambda [[x y] prev] (and prev (= x y)))
+                      true
+                      (list;zip2 xparams yparams)))
+
+      (^template []
+       [ ]
+       true)
+      ([#;VoidT] [#;UnitT])
+      
+      (^template []
+       [( xid) ( yid)]
+       (=+ yid xid))
+      ([#;VarT] [#;ExT] [#;BoundT])
+
+      (^or [(#;LambdaT xleft xright) (#;LambdaT yleft yright)]
+       [(#;AppT xleft xright) (#;AppT yleft yright)])
+      (and (= xleft yleft)
+           (= xright yright))
+
+      [(#;NamedT [xmodule xname] xtype) (#;NamedT [ymodule yname] ytype)]
+      (and (Text/= xmodule ymodule)
+           (Text/= xname yname)
+           (= xtype ytype))
+
+      (^template []
+       [( xL xR) ( yL yR)]
+       (and (= xL yL) (= xR yR)))
+      ([#;SumT] [#;ProdT])
+      
+      (^or [(#;UnivQ xenv xbody) (#;UnivQ yenv ybody)]
+       [(#;ExQ xenv xbody) (#;ExQ yenv ybody)])
+      (and (=+ (list;size yenv) (list;size xenv))
+           (= xbody ybody)
+           (List/fold (lambda [[x y] prev] (and prev (= x y)))
+                      true
+                      (list;zip2 xenv yenv)))
+
+      _
+      false
+      )))
+
+## [Values]
+(def: #export (flatten-function type)
+  (-> Type [(List Type) Type])
+  (case type
+    (#;LambdaT in out')
+    (let [[ins out] (flatten-function out')]
+      [(list& in ins) out])
+
+    _
+    [(list) type]))
+
+(def: #export (flatten-apply type)
+  (-> Type [Type (List Type)])
+  (case type
+    (#;AppT left' right)
+    (let [[left rights] (flatten-apply left')]
+      [left (List/append rights (list right))])
+
+    _
+    [type (list)]))
+
+(do-template [ ]
+  [(def: #export ( type)
+     (-> Type (List Type))
+     (case type
+       ( left right)
+       (list& left ( right))
+
+       _
+       (list type)))]
+
+  [flatten-sum  #;SumT]
+  [flatten-prod #;ProdT]
+  )
+
+(def: #export (apply-type type-fun param)
+  (-> Type Type (Maybe Type))
+  (case type-fun
+    (^template []
+     ( env body)
+     (#;Some (beta-reduce (list& type-fun param env) body)))
+    ([#;UnivQ] [#;ExQ])
+
+    (#;AppT F A)
+    (do Monad
+      [type-fn* (apply-type F A)]
+      (apply-type type-fn* param))
+
+    (#;NamedT name type)
+    (apply-type type param)
+    
+    _
+    #;None))
+
+(def: #export (type-to-ast type)
+  (-> Type AST)
+  (case type
+    (#;HostT name params)
+    (` (#;HostT (~ (ast;text name))
+                (list (~@ (List/map type-to-ast params)))))
+
+    (^template []
+     
+     (` ))
+    ([#;VoidT] [#;UnitT])
+
+    (^template []
+     ( idx)
+     (` ( (~ (ast;nat idx)))))
+    ([#;VarT] [#;ExT] [#;BoundT])
+
+    (^template []
+     ( left right)
+     (` ( (~ (type-to-ast left))
+               (~ (type-to-ast right)))))
+    ([#;LambdaT] [#;AppT])
+
+    (^template [  ]
+     ( left right)
+     (` ( (~@ (List/map type-to-ast ( type))))))
+    ([#;SumT  | flatten-sum]
+     [#;ProdT & flatten-prod])
+
+    (#;NamedT name sub-type)
+    (ast;symbol name)
+
+    (^template []
+     ( env body)
+     (` ( (list (~@ (List/map type-to-ast env)))
+               (~ (type-to-ast body)))))
+    ([#;UnivQ] [#;ExQ])
+    ))
+
+(def: #export (type-to-text type)
+  (-> Type Text)
+  (case type
+    (#;HostT name params)
+    (case params
+      #;Nil
+      ($_ Text/append "(^ " name ")")
+
+      _
+      ($_ Text/append "(^ " name " " (|> params (List/map type-to-text) list;reverse (list;interpose " ") (List/fold Text/append "")) ")"))
+
+    #;VoidT
+    "Void"
+    
+    #;UnitT
+    "Unit"
+
+    (^template [   ]
+     ( _)
+     ($_ Text/append 
+         (|> ( type)
+             (List/map type-to-text)
+             list;reverse
+             (list;interpose " ")
+             (List/fold Text/append ""))
+         ))
+    ([#;SumT  "(| " ")" flatten-sum]
+     [#;ProdT "["   "]" flatten-prod])
+
+    (#;LambdaT input output)
+    (let [[ins out] (flatten-function type)]
+      ($_ Text/append  "(-> "
+          (|> ins
+              (List/map type-to-text)
+              list;reverse
+              (list;interpose " ")
+              (List/fold Text/append ""))
+          " " (type-to-text out) ")"))
+
+    (#;BoundT idx)
+    (Nat/encode idx)
+
+    (#;VarT id)
+    ($_ Text/append "⌈v:" (Nat/encode id) "⌋")
+
+    (#;ExT id)
+    ($_ Text/append "⟨e:" (Nat/encode id) "⟩")
+
+    (#;AppT fun param)
+    (let [[type-fun type-args] (flatten-apply type)]
+      ($_ Text/append  "(" (type-to-text type-fun) " " (|> type-args (List/map type-to-text) list;reverse (list;interpose " ") (List/fold Text/append "")) ")"))
+
+    (#;UnivQ env body)
+    ($_ Text/append "(All " (type-to-text body) ")")
+
+    (#;ExQ env body)
+    ($_ Text/append "(Ex " (type-to-text body) ")")
+
+    (#;NamedT [module name] type)
+    ($_ Text/append module ";" name)
+    ))
+
+(def: #export (un-alias type)
+  (-> Type Type)
+  (case type
+    (#;NamedT _ (#;NamedT ident type'))
+    (un-alias (#;NamedT ident type'))
+
+    _
+    type))
+
+(def: #export (un-name type)
+  (-> Type Type)
+  (case type
+    (#;NamedT ident type')
+    (un-name type')
+
+    _
+    type))
diff --git a/stdlib/source/lux/type/auto.lux b/stdlib/source/lux/type/auto.lux
new file mode 100644
index 000000000..a1a795c80
--- /dev/null
+++ b/stdlib/source/lux/type/auto.lux
@@ -0,0 +1,211 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monad)
+       (data [text]
+             text/format
+             [number]
+             (struct [list "List/" Monad Fold]
+                     [dict])
+             [bool]
+             [product])
+       [compiler #+ Monad]
+       (macro [ast]
+              ["s" syntax #+ syntax: Syntax])
+       [type]
+       (type ["tc" check #+ Check Monad])
+       ))
+
+(def: (find-member-type idx sig-type)
+  (-> Nat Type (Check Type))
+  (case sig-type
+    (#;NamedT _ sig-type')
+    (find-member-type idx sig-type')
+
+    (#;AppT func arg)
+    (case (type;apply-type func arg)
+      #;None
+      (tc;fail (format "Can't apply type " (%type func) " to type " (%type arg)))
+
+      (#;Some sig-type')
+      (find-member-type idx sig-type'))
+
+    (#;ProdT left right)
+    (if (=+ +0 idx)
+      (:: Monad wrap left)
+      (find-member-type (dec+ idx) right))
+
+    _
+    (if (=+ +0 idx)
+      (:: Monad wrap sig-type)
+      (tc;fail (format "Can't find member type " (%n idx) " for " (%type sig-type))))))
+
+(def: (resolve-member member)
+  (-> Ident (Lux [Nat Type]))
+  (do Monad
+    [member (compiler;normalize member)
+     [idx tag-list sig-type] (compiler;resolve-tag member)]
+    (wrap [idx sig-type])))
+
+(def: (prepare-defs this-module-name defs)
+  (-> Text (List [Text Def]) (List [Ident Type]))
+  (|> defs
+      (list;filter (lambda [[name [def-type def-anns def-value]]]
+                     (compiler;struct? def-anns)))
+      (List/map (lambda [[name [def-type def-anns def-value]]]
+                  [[this-module-name name] def-type]))))
+
+(def: local-env
+  (Lux (List [Ident Type]))
+  (do Monad
+    [local-batches compiler;locals
+     #let [total-locals (List/fold (lambda [[name type] table]
+                                     (dict;put~ name type table))
+                                   (: (dict;Dict Text Type)
+                                      (dict;new text;Hash))
+                                   (List/join local-batches))]]
+    (wrap (|> total-locals
+              dict;entries
+              (List/map (lambda [[name type]] [["" name] type]))))))
+
+(def: local-structs
+  (Lux (List [Ident Type]))
+  (do Monad
+    [this-module-name compiler;current-module-name
+     defs (compiler;defs this-module-name)]
+    (wrap (prepare-defs this-module-name defs))))
+
+(def: import-structs
+  (Lux (List [Ident Type]))
+  (do Monad
+    [this-module-name compiler;current-module-name
+     imp-mods (compiler;imported-modules this-module-name)
+     export-batches (mapM @ compiler;exports imp-mods)]
+    (wrap (prepare-defs this-module-name (List/join export-batches)))))
+
+(def: (apply-function-type func arg)
+  (-> Type Type (Check Type))
+  (case func
+    (#;NamedT _ func')
+    (apply-function-type func' arg)
+
+    (#;UnivQ _)
+    (do Monad
+      [[id var] tc;create-var]
+      (apply-function-type (default (undefined)
+                             (type;apply-type func var))
+                           arg))
+
+    (#;LambdaT input output)
+    (do Monad
+      [_ (tc;check input arg)]
+      (wrap output))
+
+    _
+    (tc;fail (format "Invalid function type: " (%type func)))))
+
+(def: (check-apply member-type input-types output-type)
+  (-> Type (List Type) Type (Check []))
+  (do Monad
+    [member-type' (foldM Monad
+                         (lambda [input member]
+                           (apply-function-type member input))
+                         member-type
+                         input-types)]
+    (tc;check output-type member-type')))
+
+(def: compiler-type-context
+  (Lux tc;Context)
+  (lambda [compiler]
+    (let [type-vars (get@ #;type-vars compiler)
+          context (|> tc;fresh-context
+                      (set@ #tc;var-id (get@ #;counter type-vars))
+                      (set@ #tc;bindings (dict;from-list number;Hash (get@ #;mappings type-vars))))]
+      (#;Right [compiler context]))))
+
+(def: (test-alternatives sig-type member-idx input-types output-type alts)
+  (-> Type Nat (List Type) Type (List [Ident Type]) (Lux (List Ident)))
+  (do Monad
+    [context compiler-type-context]
+    (case (|> alts
+              (list;filter (lambda [[alt-name alt-type]]
+                             (case (tc;run context
+                                           (do Monad
+                                             [_ (tc;check sig-type alt-type)
+                                              member-type (find-member-type member-idx alt-type)]
+                                             (check-apply member-type input-types output-type)))
+                               (#;Left error)
+                               false
+
+                               (#;Right _)
+                               true)))
+              (List/map product;left))
+      #;Nil
+      (compiler;fail "No alternatives.")
+
+      found
+      (wrap found))))
+
+(def: (find-alternatives sig-type member-idx input-types output-type)
+  (-> Type Nat (List Type) Type (Lux (List Ident)))
+  (let [test (test-alternatives sig-type member-idx input-types output-type)]
+    ($_ compiler;either
+        (do Monad [alts local-env] (test alts))
+        (do Monad [alts local-structs] (test alts))
+        (do Monad [alts import-structs] (test alts)))))
+
+(def: (var? input)
+  (-> AST Bool)
+  (case input
+    [_ (#;SymbolS _)]
+    true
+
+    _
+    false))
+
+(def: (join-pair [l r])
+  (All [a] (-> [a a] (List a)))
+  (list l r))
+
+(syntax: #export (::: {member s;symbol}
+                      {args (s;alt (s;some s;symbol)
+                                   (s;some s;any))})
+  (case args
+    (#;Left args)
+    (do @
+      [[member-idx sig-type] (resolve-member member)
+       input-types (mapM @ compiler;find-type args)
+       output-type compiler;expected-type
+       chosen-ones (find-alternatives sig-type member-idx input-types output-type)]
+      (case chosen-ones
+        #;Nil
+        (compiler;fail (format "No structure option could be found for member " (%ident member)))
+
+        (#;Cons chosen #;Nil)
+        (wrap (list (` (:: (~ (ast;symbol chosen))
+                           (~ (ast;symbol member))
+                           (~@ (List/map ast;symbol args))))))
+
+        _
+        (compiler;fail (format "Too many available options: "
+                               (|> chosen-ones
+                                   (List/map %ident)
+                                   (text;join-with ", ")
+                                   )))))
+
+    (#;Right args)
+    (do @
+      [#let [args-to-bind (list;filter (bool;complement var?) args)]
+       labels (seqM @ (list;repeat (list;size args-to-bind)
+                                   (compiler;gensym "")))
+       #let [retry (` (let [(~@ (|> (list;zip2 labels args-to-bind) (List/map join-pair) List/join))]
+                        (;;::: (~ (ast;symbol member)) (~@ labels))))]]
+      (wrap (list retry)))))
+
+(comment
+  (::: map inc (list 0 1 2 3 4))
+  )
diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux
new file mode 100644
index 000000000..9eb72cbcb
--- /dev/null
+++ b/stdlib/source/lux/type/check.lux
@@ -0,0 +1,518 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control functor
+                applicative
+                monad)
+       (data [text "Text/" Monoid Eq]
+             text/format
+             [number]
+             maybe
+             (struct [list]
+                     [dict])
+             error)
+       [type "Type/" Eq]
+       ))
+
+(type: #export Id Nat)
+
+(type: #export Fixpoints (List [[Type Type] Bool]))
+
+(type: #export Context
+  {#var-id Id
+   #ex-id Id
+   #bindings (dict;Dict Id (Maybe Type))
+   #fixpoints Fixpoints
+   })
+
+(type: #export (Check a)
+  (-> Context (Error [Context a])))
+
+(struct: #export _ (Functor Check)
+  (def: (map f fa)
+    (lambda [context]
+      (case (fa context)
+        (#;Left error)
+        (#;Left error)
+
+        (#;Right [context' output])
+        (#;Right [context' (f output)])
+        ))))
+
+(struct: #export _ (Applicative Check)
+  (def: functor Functor)
+
+  (def: (wrap x)
+    (lambda [context]
+      (#;Right [context x])))
+
+  (def: (apply ff fa)
+    (lambda [context]
+      (case (ff context)
+        (#;Right [context' f])
+        (case (fa context')
+          (#;Right [context'' a])
+          (#;Right [context'' (f a)])
+
+          (#;Left error)
+          (#;Left error))
+
+        (#;Left error)
+        (#;Left error)
+        )))
+  )
+
+(struct: #export _ (Monad Check)
+  (def: applicative Applicative)
+
+  (def: (join ffa)
+    (lambda [context]
+      (case (ffa context)
+        (#;Right [context' fa])
+        (case (fa context')
+          (#;Right [context'' a])
+          (#;Right [context'' a])
+
+          (#;Left error)
+          (#;Left error))
+
+        (#;Left error)
+        (#;Left error)
+        )))
+  )
+
+(open Monad "Check/")
+
+## [[Logic]]
+(def: #export (run context proc)
+  (All [a] (-> Context (Check a) (Error a)))
+  (case (proc context)
+    (#;Left error)
+    (#;Left error)
+
+    (#;Right [context' output])
+    (#;Right output)))
+
+(def: (apply-type! t-func t-arg)
+  (-> Type Type (Check Type))
+  (lambda [context]
+    (case (type;apply-type t-func t-arg)
+      #;None
+      (#;Left (format "Invalid type application: " (type;type-to-text t-func) " on " (type;type-to-text t-arg)))
+
+      (#;Some output)
+      (#;Right [context output]))))
+
+(def: #export existential
+  (Check [Id Type])
+  (lambda [context]
+    (let [id (get@ #ex-id context)]
+      (#;Right [(update@ #ex-id inc+ context)
+                [id (#;ExT id)]]))))
+
+(def: (bound? id)
+  (-> Id (Check Bool))
+  (lambda [context]
+    (case (|> context (get@ #bindings) (dict;get id))
+      (#;Some (#;Some _))
+      (#;Right [context true])
+
+      (#;Some #;None)
+      (#;Right [context false])
+      
+      #;None
+      (#;Left (format "Unknown type-var: " (%n id))))))
+
+(def: (deref id)
+  (-> Id (Check Type))
+  (lambda [context]
+    (case (|> context (get@ #bindings) (dict;get id))
+      (#;Some (#;Some type))
+      (#;Right [context type])
+
+      (#;Some #;None)
+      (#;Left (format "Unbound type-var: " (%n id)))
+      
+      #;None
+      (#;Left (format "Unknown type-var: " (%n id))))))
+
+(def: (set-var id type)
+  (-> Id Type (Check []))
+  (lambda [context]
+    (case (|> context (get@ #bindings) (dict;get id))
+      (#;Some (#;Some bound))
+      (#;Left (format "Can't rebind type-var: " (%n id) " | Current type: " (type;type-to-text bound)))
+      
+      (#;Some #;None)
+      (#;Right [(update@ #bindings (dict;put id (#;Some type)) context)
+                []])
+
+      #;None
+      (#;Left (format "Unknown type-var: " (%n id))))))
+
+(def: (reset-var id type)
+  (-> Id Type (Check []))
+  (lambda [context]
+    (case (|> context (get@ #bindings) (dict;get id))
+      (#;Some _)
+      (#;Right [(update@ #bindings (dict;put id (#;Some type)) context)
+                []])
+      
+      #;None
+      (#;Left (format "Unknown type-var: " (%n id))))))
+
+(def: (unset-var id)
+  (-> Id (Check []))
+  (lambda [context]
+    (case (|> context (get@ #bindings) (dict;get id))
+      (#;Some _)
+      (#;Right [(update@ #bindings (dict;put id #;None) context)
+                []])
+      
+      #;None
+      (#;Left (format "Unknown type-var: " (%n id))))))
+
+(def: (clean t-id type)
+  (-> Id Type (Check Type))
+  (case type
+    (#;VarT id)
+    (if (=+ t-id id)
+      (do Monad
+        [? (bound? id)]
+        (if ?
+          (deref id)
+          (wrap type)))
+      (do Monad
+        [? (bound? id)]
+        (if ?
+          (do Monad
+            [=type (deref id)
+             ==type (clean t-id =type)]
+            (case ==type
+              (#;VarT =id)
+              (if (=+ t-id =id)
+                (do Monad
+                  [_ (unset-var id)]
+                  (wrap type))
+                (do Monad
+                  [_ (reset-var id ==type)]
+                  (wrap type)))
+
+              _
+              (do Monad
+                [_ (reset-var id ==type)]
+                (wrap type))))
+          (wrap type))))
+
+    (#;HostT name params)
+    (do Monad
+      [=params (mapM @ (clean t-id) params)]
+      (wrap (#;HostT name =params)))
+    
+    (^template []
+     ( left right)
+     (do Monad
+       [=left (clean t-id left)
+        =right (clean t-id right)]
+       (wrap ( =left =right))))
+    ([#;LambdaT]
+     [#;AppT]
+     [#;ProdT]
+     [#;SumT])
+
+    (^template []
+     ( env body)
+     (do Monad
+       [=env (mapM @ (clean t-id) env)
+        =body (clean t-id body)] ## TODO: DON'T CLEAN THE BODY
+       (wrap ( =env =body))))
+    ([#;UnivQ]
+     [#;ExQ])
+    
+    _
+    (:: Monad wrap type)
+    ))
+
+(def: #export create-var
+  (Check [Id Type])
+  (lambda [context]
+    (let [id (get@ #var-id context)]
+      (#;Right [(|> context
+                    (update@ #var-id inc+)
+                    (update@ #bindings (dict;put id #;None)))
+                [id (#;VarT id)]]))))
+
+(do-template [   ]
+  [(def: 
+     (Check )
+     (lambda [context]
+       (#;Right [context
+                 (get@  context)])))
+
+   (def: ( value)
+     (->  (Check []))
+     (lambda [context]
+       (#;Right [(set@  value context)
+                 []])))]
+
+  [get-bindings  set-bindings  #bindings  (dict;Dict Id (Maybe Type))]
+  [get-fixpoints set-fixpoints #fixpoints Fixpoints]
+  )
+
+(def: #export (delete-var id)
+  (-> Id (Check []))
+  (do Monad
+    [? (bound? id)
+     _ (if ?
+         (wrap [])
+         (do Monad
+           [[ex-id ex] existential]
+           (set-var id ex)))
+     bindings get-bindings
+     bindings' (mapM @
+                     (lambda [(^@ binding [b-id b-type])]
+                       (if (=+ id b-id)
+                         (wrap binding)
+                         (case b-type
+                           #;None
+                           (wrap binding)
+
+                           (#;Some b-type')
+                           (case b-type'
+                             (#;VarT t-id)
+                             (if (=+ id t-id)
+                               (wrap [b-id #;None])
+                               (wrap binding))
+
+                             _
+                             (do Monad
+                               [b-type'' (clean id b-type')]
+                               (wrap [b-id (#;Some b-type'')])))
+                           )))
+                     (dict;entries bindings))]
+    (set-bindings (|> bindings' (dict;from-list number;Hash) (dict;remove id)))))
+
+(def: #export (with-var k)
+  (All [a] (-> (-> [Id Type] (Check a)) (Check a)))
+  (do Monad
+    [[id var] create-var
+     output (k [id var])
+     _ (delete-var id)]
+    (wrap output)))
+
+(def: #export fresh-context
+  Context
+  {#var-id +0
+   #ex-id +0
+   #bindings (dict;new number;Hash)
+   #fixpoints (list)
+   })
+
+(def: (attempt op)
+  (All [a] (-> (Check a) (Check (Maybe a))))
+  (lambda [context]
+    (case (op context)
+      (#;Right [context' output])
+      (#;Right [context' (#;Some output)])
+
+      (#;Left _)
+      (#;Right [context #;None]))))
+
+(def: #export (fail message)
+  (All [a] (-> Text (Check a)))
+  (lambda [context]
+    (#;Left message)))
+
+(def: (fail-check expected actual)
+  (-> Type Type (Check []))
+  (fail (format "Expected: " (type;type-to-text expected) "\n\n"
+                "Actual:   " (type;type-to-text actual))))
+
+(def: success (Check []) (Check/wrap []))
+
+(def: (|| left right)
+  (All [a] (-> (Check a) (Check a) (Check a)))
+  (lambda [context]
+    (case (left context)
+      (#;Right [context' output])
+      (#;Right [context' output])
+
+      (#;Left _)
+      (right context))))
+
+(def: (fp-get [e a] fixpoints)
+  (-> [Type Type] Fixpoints (Maybe Bool))
+  (list;find (lambda [[[fe fa] status]]
+               (if (and (Type/= e fe)
+                        (Type/= a fa))
+                 (#;Some status)
+                 #;None))
+             fixpoints))
+
+(def: (fp-put ea status fixpoints)
+  (-> [Type Type] Bool Fixpoints Fixpoints)
+  (#;Cons [ea status] fixpoints))
+
+(def: #export (check expected actual)
+  (-> Type Type (Check []))
+  (if (== expected actual)
+    success
+    (case [expected actual]
+      [(#;VarT e-id) (#;VarT a-id)]
+      (if (=+ e-id a-id)
+        success
+        (do Monad
+          [ebound (attempt (deref e-id))
+           abound (attempt (deref a-id))]
+          (case [ebound abound]
+            [#;None #;None]
+            (set-var e-id actual)
+            
+            [(#;Some etype) #;None]
+            (check etype actual)
+
+            [#;None (#;Some atype)]
+            (check expected atype)
+
+            [(#;Some etype) (#;Some atype)]
+            (check etype atype))))
+      
+      [(#;VarT id) _]
+      (|| (set-var id actual)
+          (do Monad
+            [bound (deref id)]
+            (check bound actual)))
+      
+      [_ (#;VarT id)]
+      (|| (set-var id expected)
+          (do Monad
+            [bound (deref id)]
+            (check expected bound)))
+
+      [(#;AppT (#;ExT eid) eA) (#;AppT (#;ExT aid) aA)]
+      (if (=+ eid aid)
+        (check eA aA)
+        (fail-check expected actual))
+
+      [(#;AppT (#;VarT id) A1) (#;AppT F2 A2)]
+      (|| (do Monad
+            [F1 (deref id)]
+            (check (#;AppT F1 A1) actual))
+          (do Monad
+            [_ (check (#;VarT id) F2)
+             e' (apply-type! F2 A1)
+             a' (apply-type! F2 A2)]
+            (check e' a')))
+      
+      [(#;AppT F1 A1) (#;AppT (#;VarT id) A2)]
+      (|| (do Monad
+            [F2 (deref id)]
+            (check expected (#;AppT F2 A2)))
+          (do Monad
+            [_ (check F1 (#;VarT id))
+             e' (apply-type! F1 A1)
+             a' (apply-type! F1 A2)]
+            (check e' a')))
+
+      [(#;AppT F A) _]
+      (do Monad
+        [#let [fp-pair [expected actual]]
+         fixpoints get-fixpoints]
+        (case (fp-get fp-pair fixpoints)
+          (#;Some ?)
+          (if ?
+            success
+            (fail-check expected actual))
+
+          #;None
+          (do Monad
+            [expected' (apply-type! F A)
+             _ (set-fixpoints (fp-put fp-pair true fixpoints))]
+            (check expected' actual))))
+
+      [_ (#;AppT F A)]
+      (do Monad
+        [actual' (apply-type! F A)]
+        (check expected actual'))
+
+      [(#;UnivQ _) _]
+      (do Monad
+        [[ex-id ex] existential
+         expected' (apply-type! expected ex)]
+        (check expected' actual))
+
+      [_ (#;UnivQ _)]
+      (with-var
+        (lambda [[var-id var]]
+          (do Monad
+            [actual' (apply-type! actual var)
+             =output (check expected actual')
+             _ (clean var-id expected)]
+            success)))
+
+      [(#;ExQ e!env e!def) _]
+      (with-var
+        (lambda [[var-id var]]
+          (do Monad
+            [expected' (apply-type! expected var)
+             =output (check expected' actual)
+             _ (clean var-id actual)]
+            success)))
+
+      [_ (#;ExQ a!env a!def)]
+      (do Monad
+        [[ex-id ex] existential
+         actual' (apply-type! actual ex)]
+        (check expected actual'))
+
+      [(#;HostT e-name e-params) (#;HostT a-name a-params)]
+      (if (Text/= e-name a-name)
+        (do Monad
+          [_ (mapM Monad
+                   (lambda [[e a]] (check e a))
+                   (list;zip2 e-params a-params))]
+          success)
+        (fail-check expected actual))
+
+      (^template [ ]
+       [ ]
+       success
+       
+       [( eL eR) ( aL aR)]
+       (do Monad
+         [_ (check eL aL)]
+         (check eR aR)))
+      ([#;VoidT #;SumT]
+       [#;UnitT #;ProdT])
+      
+      [(#;LambdaT eI eO) (#;LambdaT aI aO)]
+      (do Monad
+        [_ (check aI eI)]
+        (check eO aO))
+
+      [(#;ExT e!id) (#;ExT a!id)]
+      (if (=+ e!id a!id)
+        success
+        (fail-check expected actual))
+
+      [(#;NamedT _ ?etype) _]
+      (check ?etype actual)
+
+      [_ (#;NamedT _ ?atype)]
+      (check expected ?atype)
+
+      _
+      (fail-check expected actual))))
+
+(def: #export (checks? expected actual)
+  (-> Type Type Bool)
+  (case (run fresh-context (check expected actual))
+    (#;Left error)
+    false
+
+    (#;Right _)
+    true))
diff --git a/stdlib/test/test/lux.lux b/stdlib/test/test/lux.lux
new file mode 100644
index 000000000..947ec5b6f
--- /dev/null
+++ b/stdlib/test/test/lux.lux
@@ -0,0 +1,164 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  lux/test
+  (lux (control monad)
+       (codata [io])
+       [math]
+       (math ["R" random])
+       (data text/format)
+       [compiler]
+       (macro ["s" syntax #+ syntax:])))
+
+(test: "Every value is identical to itself, and the 'id' function doesn't change values in any way."
+  [value R;int]
+  (assert "" (and (== value value)
+                  (== value (id value)))))
+
+(test: "Values created separately can't be identical."
+  [x R;int
+   y R;int]
+  (match false (== x y)))
+
+(do-template [category rand-gen inc dec even? odd? = < >]
+  [(test: (format "[" category "] " "Moving up-down or down-up should result in same value.")
+     [value rand-gen]
+     (assert "" (and (|> value inc dec (= value))
+                     (|> value dec inc (= value)))))
+
+   (test: (format "[" category "] " "(x+1) > x && (x-1) < x")
+     [value rand-gen]
+     (assert "" (and (|> value inc (> value))
+                     (|> value dec (< value)))))
+
+   (test: (format "[" category "] " "Every odd/even number is surrounded by two of the other kind.")
+     [value rand-gen]
+     (assert ""
+             (if (even? value)
+               (and (|> value inc odd?)
+                    (|> value dec odd?))
+               (and (|> value inc even?)
+                    (|> value dec even?)))))]
+
+  ["Nat" R;nat inc+ dec+ even?+ odd?+ =+ <+ >+]
+  ["Int" R;int inc  dec  even?  odd?  =  <  >]
+  )
+
+(do-template [category rand-gen = < > <= >= min max]
+  [(test: (format "[" category "] " "The symmetry of numerical comparisons.")
+     [x rand-gen
+      y rand-gen]
+     (assert ""
+             (or (= x y)
+                 (if (< y x)
+                   (> x y)
+                   (< x y)))))
+
+   (test: (format "[" category "] " "Minimums and maximums.")
+     [x rand-gen
+      y rand-gen]
+     (assert ""
+             (and (and (<= x (min x y))
+                       (<= y (min x y)))
+                  (and (>= x (max x y))
+                       (>= y (max x y)))
+                  )))]
+
+  ["Int"  R;int  =   <   >   <=   >=   min   max]
+  ["Nat"  R;nat  =+  <+  >+  <=+  >=+  min+  max+]
+  ["Real" R;real =.  <.  >.  <=.  >=.  min.  max.]
+  ["Frac" R;frac =.. <.. >.. <=.. >=.. min.. max..]
+  )
+
+(do-template [category rand-gen = + - * / <%> > <0> <1> <10> %x  ]
+  [(test: (format "[" category "] " "Additive identity")
+     [x rand-gen]
+     (assert ""
+             (and (|> x (+ <0>) (= x))
+                  (|> x (- <0>) (= x)))))
+
+   (test: (format "[" category "] " "Addition & Substraction")
+     [x (:: @ map  rand-gen)
+      y (:: @ map  rand-gen)
+      #let [x (* <10> x)
+            y (* <10> y)
+            cond (and (|> x (- y) (+ y) (= x))
+                      (|> x (+ y) (- y) (= x)))
+            _ (if cond
+                []
+                (exec
+                  (log! "+- SAMPLE")
+                  (log! (format (%x x) " -+ " (%x y) " = " (%x (|> x (- y) (+ y)))))
+                  (log! (format (%x x) " +- " (%x y) " = " (%x (|> x (+ y) (- y)))))))
+            ]]
+     (assert ""
+             (and (|> x (- y) (+ y) (= x))
+                  (|> x (+ y) (- y) (= x)))))
+
+   (test: (format "[" category "] " "Multiplicative identity")
+     [x rand-gen]
+     (assert ""
+             (and (|> x (* <1>) (= x))
+                  (|> x (/ <1>) (= x)))))
+
+   (test: (format "[" category "] " "Multiplication & Division")
+     [x (:: @ map  rand-gen)
+      y (|> rand-gen
+            (:: @ map )
+            (R;filter (|>. (= <0>) not)))
+      #let [r (<%> y x)
+            x' (- r x)]]
+     (assert ""
+             (or (> x' y)
+                 (|> x' (/ y) (* y) (= x')))
+             ))]
+
+  ["Nat"  R;nat  =+ ++ -+ *+ /+ ;%+ >+ +0  +1   +1000000   %n (;%+ +1000) id]
+  ["Int"  R;int  =  +  -  *  /  ;%  >   0   1    1000000   %i (;%   1000) id]
+  ["Real" R;real =. +. -. *. /. ;%. >.  0.0 1.0  1000000.0 %r id          math;floor]
+  )
+
+(do-template [category rand-gen -> <- =  %a %z]
+  [(test: (format "[" category "] " "Numeric conversions")
+     [value rand-gen
+      #let [value ( value)]]
+     (assert ""
+             (|> value -> <- (= value))))]
+
+  ["Int->Nat"  R;int  int-to-nat  nat-to-int  =  (;%  1000000)   %i %n]
+  ["Nat->Int"  R;nat  nat-to-int  int-to-nat  =+ (;%+ +1000000)  %n %i]
+  ["Int->Real" R;int  int-to-real real-to-int =  (;%  1000000)   %i %r]
+  ["Real->Int" R;real real-to-int int-to-real =. math;floor %r %i]
+  ## [R;real real-to-frac frac-to-real =. (;%. 1.0) %r %f]
+  )
+
+(test: "Simple macros and constructs"
+  (all (match ["lux" "yolo"] (ident-for ;yolo))
+       (match ["test/lux" "yolo"] (ident-for ;;yolo))
+       (match ["" "yolo"] (ident-for yolo))
+       (match ["lux/test" "yolo"] (ident-for lux/test;yolo))
+       (match ["lux" "yolo"] (ident-for #;yolo))
+       (match ["test/lux" "yolo"] (ident-for #;;yolo))
+       (match ["" "yolo"] (ident-for #yolo))
+       (match ["lux/test" "yolo"] (ident-for #lux/test;yolo))
+
+       (match 1000 (loop [counter 0
+                          value 1]
+                     (if (< 3 counter)
+                       (recur (inc counter) (* 10 value))
+                       value)))
+
+       (match (^ (list 1 2 3))
+              (list 1 2 3))
+       (match (^ (list 1 2 3 4 5 6))
+              (list& 1 2 3 (list 4 5 6)))
+
+       (match "yolo" (default "yolo"
+                       #;None))
+       (match "lol" (default "yolo"
+                      (#;Some "lol")))
+       ))
diff --git a/stdlib/test/test/lux/cli.lux b/stdlib/test/test/lux/cli.lux
new file mode 100644
index 000000000..c95ec9e9c
--- /dev/null
+++ b/stdlib/test/test/lux/cli.lux
@@ -0,0 +1,84 @@
+(;module:
+  [lux #- not]
+  (lux (codata [io])
+       (control monad)
+       (data text/format
+             [number]
+             [product]
+             [sum])
+       (codata function)
+       [cli #- run])
+  [lux/test #-  assert])
+
+(test: "lux/cli exports"
+  (test-all (match (#;Right "foo")
+                   (cli;run any (list "foo" "bar" "baz")))
+            (match (#;Left _)
+                   (cli;run any (list)))
+            (match (#;Right 123)
+                   (cli;run (parse (:: number;Codec decode) any) (list "123")))
+            (match (#;Left _)
+                   (cli;run (option (list "-p" "--port")) (list)))
+            (match (#;Left _)
+                   (cli;run (option (list "-p" "--port")) (list "yolo")))
+            (match (#;Right "123")
+                   (cli;run (option (list "-p" "--port")) (list "-p" "123")))
+            (match (#;Right "123")
+                   (cli;run (option (list "-p" "--port")) (list "--port" "123")))
+            (match (#;Right false)
+                   (cli;run (flag (list "-h" "--help")) (list)))
+            (match (#;Right false)
+                   (cli;run (flag (list "-h" "--help")) (list "yolo")))
+            (match (#;Right true)
+                   (cli;run (flag (list "-h" "--help")) (list "-h")))
+            (match (#;Right true)
+                   (cli;run (flag (list "-h" "--help")) (list "--help")))
+            (match (#;Right [])
+                   (cli;run end (list)))
+            (match (#;Left _)
+                   (cli;run end (list "yolo")))
+            (match (#;Left "YOLO")
+                   (cli;run (assert false "YOLO") (list "yolo")))
+            (match (#;Right [])
+                   (cli;run (assert true "YOLO") (list "yolo")))
+            (match (#;Right #;None)
+                   (cli;run (opt any) (list)))
+            (match (#;Right (#;Some "yolo"))
+                   (cli;run (opt any) (list "yolo")))
+            (match (#;Right ["foo" "bar"])
+                   (cli;run (seq any any) (list "foo" "bar" "baz")))
+            (match (#;Right ["foo" "bar"])
+                   (cli;run (seq any any) (list "foo" "bar")))
+            (match (#;Left _)
+                   (cli;run (seq any any) (list "foo")))
+            ## (match (#;Right (#;Left 123))
+            ##          (cli;run (alt (parse (:: number;Codec decode) any)
+            ##                       any)
+            ##                   (list "123" "foo")))
+            ## (match (#;Right (#;Right "foo"))
+            ##          (cli;run (alt (parse (:: number;Codec decode) any)
+            ##                       any)
+            ##                   (list "foo")))
+            (match (#;Left _)
+                   (cli;run (alt (parse (:: number;Codec decode) any)
+                                 (parse (:: number;Codec decode) any))
+                            (list "foo")))
+            (match (#;Left _)
+                   (cli;run (not (parse (:: number;Codec decode) any))
+                            (list "123")))
+            (match (#;Right [])
+                   (cli;run (not (parse (:: number;Codec decode) any))
+                            (list "yolo")))
+            (match (^ (#;Right (list "foo" "bar" "baz")))
+                   (cli;run (some any) (list "foo" "bar" "baz")))
+            (match (^ (#;Right (list)))
+                   (cli;run (some any) (list)))
+            (match (^ (#;Right (list "foo" "bar" "baz")))
+                   (cli;run (many any) (list "foo" "bar" "baz")))
+            (match (#;Left _)
+                   (cli;run (many any) (list)))
+            (match (#;Right "yolo")
+                   (cli;run (either (parse sum;right any)
+                                    any)
+                            (list "yolo")))
+            ))
diff --git a/stdlib/test/test/lux/codata/env.lux b/stdlib/test/test/lux/codata/env.lux
new file mode 100644
index 000000000..7a374cd4d
--- /dev/null
+++ b/stdlib/test/test/lux/codata/env.lux
@@ -0,0 +1,23 @@
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data [text "Text/" Monoid]
+             text/format
+             [number])
+       (codata function
+               env))
+  lux/test)
+
+(test: "lux/codata/env exports"
+  (test-all (match 123 (run 123 ask))
+            (match 246 (run 123 (local (* 2) ask)))
+            (match 134 (run 123 (:: Functor map inc (+ 10))))
+            (match 10 (run 123 (:: Applicative wrap 10)))
+            (match 30 (run 123 (let [(^open) Applicative]
+                                 (apply (wrap (+ 10)) (wrap 20)))))
+            (match 30 (run 123 (do Monad
+                                 [f (wrap +)
+                                  x (wrap 10)
+                                  y (wrap 20)]
+                                 (wrap (f x y)))))))
diff --git a/stdlib/test/test/lux/codata/io.lux b/stdlib/test/test/lux/codata/io.lux
new file mode 100644
index 000000000..5d521faff
--- /dev/null
+++ b/stdlib/test/test/lux/codata/io.lux
@@ -0,0 +1,21 @@
+(;module:
+  lux
+  (lux (control monad)
+       (data [text "Text/" Monoid]
+             text/format
+             [number])
+       (codata function
+               io))
+  lux/test)
+
+(test: "lux/codata/io exports"
+  (test-all (match "YOLO" (run (io "YOLO")))
+            (match 11 (run (:: Functor map inc (io 10))))
+            (match 10 (run (:: Applicative wrap 10)))
+            (match 30 (run (let [(^open) Applicative]
+                             (apply (wrap (+ 10)) (wrap 20)))))
+            (match 30 (run (do Monad
+                             [f (wrap +)
+                              x (wrap 10)
+                              y (wrap 20)]
+                             (wrap (f x y)))))))
diff --git a/stdlib/test/test/lux/codata/state.lux b/stdlib/test/test/lux/codata/state.lux
new file mode 100644
index 000000000..054b59d45
--- /dev/null
+++ b/stdlib/test/test/lux/codata/state.lux
@@ -0,0 +1,34 @@
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data [text "Text/" Monoid]
+             text/format
+             [number]
+             [product])
+       (codata function
+               state))
+  lux/test)
+
+(test: "lux/codata/state exports"
+  (test-all (match 123 (product;right (run 123 get)))
+            (match 321 (product;right (run 123 (do Monad
+                                                 [_ (put 321)]
+                                                 get))))
+            (match 369 (product;right (run 123 (do Monad
+                                                 [_ (update (* 3))]
+                                                 get))))
+            (match 124 (product;right (run 123 (use inc))))
+            (match 246 (product;right (run 123 (local (* 2) get))))
+            (match 124 (product;right (run 123 (:: Functor map inc get))))
+            (match 10 (product;right (run 123 (:: Applicative wrap 10))))
+            (match 30 (product;right (run 123 (let [(^open) Applicative]
+                                                (apply (wrap (+ 10)) (wrap 20))))))
+            (match 30 (product;right (run 123 (: (State Int Int)
+                                                 (do Monad
+                                                   [f (wrap +)
+                                                    x (wrap 10)
+                                                    y (wrap 20)]
+                                                   
+                                                   (wrap (f x y)))))))
+            ))
diff --git a/stdlib/test/test/lux/codata/struct/stream.lux b/stdlib/test/test/lux/codata/struct/stream.lux
new file mode 100644
index 000000000..28292a405
--- /dev/null
+++ b/stdlib/test/test/lux/codata/struct/stream.lux
@@ -0,0 +1,68 @@
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad
+                comonad)
+       (data [text "Text/" Monoid]
+             text/format
+             [number "Int/" Codec])
+       (codata function
+               [cont]
+               (struct stream)))
+  lux/test)
+
+(test: "lux/codata/stream exports"
+  (let% [ (do-template [   ]
+                             [(match (^ (list 0 1 2))
+                                     (  (iterate inc 0)))
+                              (match (^=> (^stream& w x y z ...)
+                                          {[w x y z] [3 4 5 6]})
+                                     (  (iterate inc 0)))
+                              (match (^=> (^ [(list 0 1 2) _stream_])
+                                          {_stream_ (^stream& w x y z ...)}
+                                          {[w x y z] [3 4 5 6]})
+                                     (  (iterate inc 0)))]
+
+                             [take       drop       split      +3]
+                             [take-while drop-while split-with (< 3)])
+         ]
+    (test-all (match (^=> (^stream& w x y z ...)
+                          {[w x y z] [0 1 2 3]})
+                     (iterate inc 0))
+              (match (^=> (^stream& w x y z ...)
+                          {[w x y z] [0 0 0 0]})
+                     (repeat 0))
+              (match (^=> (#;Some the-stream)
+                          {the-stream (^stream& w x y z ...)}
+                          {[w x y z] [0 1 0 1]})
+                     (cycle (list 0 1)))
+              (match 0 (head (iterate inc 0)))
+              (match (^=> (^stream& w x y z ...)
+                          {[w x y z] [1 2 3 4]})
+                     (tail (iterate inc 0)))
+              (match 9 (at +9 (iterate inc 0)))
+              (match 0 (at +0 (iterate inc 0)))
+              
+              (match (^=> (^stream& w x y z ...)
+                          {[w x y z] ["0" "1" "2" "3"]})
+                     (unfold (lambda [n] [(inc n) (Int/encode n)])
+                             0))
+              (match (^=> (^stream& w x y z ...)
+                          {[w x y z] [0 2 4 6]})
+                     (filter even? (iterate inc 0)))
+              (match (^=> [e_stream o_stream]
+                          {e_stream (^stream& w x y z ...)}
+                          {o_stream (^stream& a b c d ...)}
+                          {[w x y z a b c d] [0 2 4 6 1 3 5 7]})
+                     (partition even? (iterate inc 0)))
+              (match (^=> (^stream& w x y z ...)
+                          {[w x y z] [0 1 4 9]})
+                     (let [square (lambda [n] (* n n))]
+                       (:: Functor map square (iterate inc 0))))
+              (match (^=> (^stream& w x y z ...)
+                          {[w x y z] [4 9 16 25]})
+                     (let [square (lambda [n] (* n n))]
+                       (be CoMonad
+                         [inputs (iterate inc 2)]
+                         (square (head inputs)))))
+              )))
diff --git a/stdlib/test/test/lux/concurrency/actor.lux b/stdlib/test/test/lux/concurrency/actor.lux
new file mode 100644
index 000000000..e9a19e8ea
--- /dev/null
+++ b/stdlib/test/test/lux/concurrency/actor.lux
@@ -0,0 +1,70 @@
+(;module:
+  lux
+  (lux (control monad)
+       (data [number]
+             text/format
+             error)
+       (concurrency [promise #+ Promise Monad "Promise/" Monad]
+                    actor)
+       (codata function
+               [io #- run]))
+  lux/test)
+
+(actor: Adder
+  Int
+
+  (method: (add! {offset Int})
+    [Int Int]
+    (let [*state*' (+ offset *state*)]
+      (wrap (#;Right [*state*' [*state* *state*']]))))
+  
+  (stop:
+    (exec (log! (format "Cause of death: " (default "???" *cause*)))
+      (log! (format "Current state: " (%i *state*)))
+      (wrap []))))
+
+(test: "lux/concurrency/actor exports"
+  (let [counter-proc (: (Proc Int (Promise Int))
+                        [(lambda [self output state]
+                           (let [state' (inc state)]
+                             (exec (io;run (promise;resolve state' output))
+                               (Promise/wrap (#;Right state')))))
+                         (lambda [?error state] (Promise/wrap []))])]
+    (test-all (match true
+                     (let [counter (: (Actor Int (Promise Int))
+                                      (io;run (spawn 0 counter-proc)))]
+                       (alive? counter)))
+              (match [true false]
+                     (let [counter (: (Actor Int (Promise Int))
+                                      (io;run (spawn 0 counter-proc)))]
+                       [(io;run (poison counter))
+                        (alive? counter)]))
+              (match [true false]
+                     (let [counter (: (Actor Int (Promise Int))
+                                      (io;run (spawn 0 counter-proc)))]
+                       [(io;run (poison counter))
+                        (io;run (poison counter))]))
+              (match+ [1 2 3]
+                      (do Monad
+                        [#let [counter (: (Actor Int (Promise Int))
+                                          (io;run (spawn 0 counter-proc)))
+                               output-1 (: (Promise Int) (promise;promise))
+                               output-2 (: (Promise Int) (promise;promise))
+                               output-3 (: (Promise Int) (promise;promise))]
+                         ?1 (send output-1 counter)
+                         ?2 (send output-2 counter)
+                         ?3 (send output-3 counter)]
+                        (if (and ?1 ?2 ?3)
+                          (from-promise ($_ promise;seq output-1 output-2 output-3))
+                          (wrap (#;Left "Uh, oh...")))))
+              (match+ [[0 1] [1 3] [3 6]]
+                      (do Monad
+                        [#let [adder (: Adder
+                                        (io;run (spawn 0 Adder//new)))]
+                         t1 (add! 1 adder)
+                         t2 (add! 2 adder)
+                         t3 (add! 3 adder)
+                         #let [? (io;run (poison adder))]]
+                        (wrap (#;Right [t1 t2 t3]))
+                        ))
+              )))
diff --git a/stdlib/test/test/lux/concurrency/frp.lux b/stdlib/test/test/lux/concurrency/frp.lux
new file mode 100644
index 000000000..62ca0b57d
--- /dev/null
+++ b/stdlib/test/test/lux/concurrency/frp.lux
@@ -0,0 +1,54 @@
+(;module:
+  lux
+  (lux (control monad)
+       (data [number]
+             text/format
+             error)
+       (concurrency [promise #+ Promise Monad "Promise/" Monad]
+                    frp)
+       (codata function
+               io))
+  lux/test)
+
+(def: (List->Chan values)
+  (-> (List Int) (Chan Int))
+  (let [_chan (: (Chan Int) (chan))]
+    (run (do Monad
+           [_ (mapM Monad
+                    (lambda [value]
+                      (write value _chan))
+                    values)
+            _ (close _chan)]
+           (wrap _chan)))))
+
+(test: "lux/concurrency/frp exports"
+  (test-all (match+ (^ (list 0 1 2 3 4 5))
+                    (from-promise (consume (List->Chan (list 0 1 2 3 4 5)))))
+            (match+ (^ (list 0 1 2 3 4 5))
+                    (from-promise (consume (let [input (List->Chan (list 0 1 2 3 4 5))
+                                               output (: (Chan Int) (chan))]
+                                           (exec (pipe input output)
+                                             output)))))
+            (match+ (^ (list 0 2 4))
+                    (from-promise (consume (filter even? (List->Chan (list 0 1 2 3 4 5))))))
+            (match+ (^ (list 0 1 2 3 4 5 0 -1 -2 -3 -4 -5))
+                    (from-promise (consume (merge (list (List->Chan (list 0 1 2 3 4 5))
+                                                      (List->Chan (list 0 -1 -2 -3 -4 -5)))))))
+            (match+ 15 (from-promise (fold (lambda [base input] (Promise/wrap (+ input base))) 0 (List->Chan (list 0 1 2 3 4 5)))))
+            (match+ (^ (list 0 1 2 3 4 5))
+                    (from-promise (consume (no-dups number;Eq (List->Chan (list 0 0 0 1 2 2 3 3 3 3 4 4 4 5 5))))))
+            (match+ (^ (list 12345))
+                    (from-promise (consume (as-chan (:: promise;Monad wrap 12345)))))
+            (match+ (^ (list 1 2 3 4 5 6))
+                    (from-promise (consume (:: Functor map inc (List->Chan (list 0 1 2 3 4 5))))))
+            (match+ (^ (list 12345))
+                    (from-promise (consume (:: Applicative wrap 12345))))
+            (match+ (^ (list 12346))
+                    (from-promise (consume (let [(^open) Applicative]
+                                           (apply (wrap inc) (wrap 12345))))))
+            (match+ (^ (list 12346))
+                    (from-promise (consume (do Monad
+                                           [f (wrap inc)
+                                            a (wrap 12345)]
+                                           (wrap (f a))))))
+            ))
diff --git a/stdlib/test/test/lux/concurrency/promise.lux b/stdlib/test/test/lux/concurrency/promise.lux
new file mode 100644
index 000000000..77e5a0aed
--- /dev/null
+++ b/stdlib/test/test/lux/concurrency/promise.lux
@@ -0,0 +1,31 @@
+(;module:
+  lux
+  (lux (control monad)
+       (data [number]
+             text/format
+             error)
+       (concurrency promise)
+       (codata function
+               [io #*]))
+  lux/test)
+
+(test: "lux/concurrency/promise exports"
+  (test-all (match+ true (from-promise (future (io true))))
+            (match+ [] (from-promise (wait +500)))
+            (match+ [true false] (from-promise (seq (future (io true))
+                                                  (future (io false)))))
+            (match+ (#;Left true) (from-promise (alt (delay +100 true)
+                                                   (delay +200 false))))
+            (match+ (#;Right false) (from-promise (alt (delay +200 true)
+                                                     (delay +100 false))))
+            (match+ true (from-promise (either (delay +100 true)
+                                             (delay +200 false))))
+            (match+ false (from-promise (either (delay +200 true)
+                                              (delay +100 false))))
+            (match (#;Some true) (poll (:: Monad wrap true)))
+            (match #;None (poll (delay +200 true)))
+            (match false (io;run (resolve false (:: Monad wrap true))))
+            (match true (io;run (resolve true (: (Promise Bool) (promise)))))
+            (match+ #;None (from-promise (time-out +100 (delay +200 true))))
+            (match+ (#;Some true) (from-promise (time-out +200 (delay +100 true))))
+            ))
diff --git a/stdlib/test/test/lux/concurrency/stm.lux b/stdlib/test/test/lux/concurrency/stm.lux
new file mode 100644
index 000000000..e29a5294b
--- /dev/null
+++ b/stdlib/test/test/lux/concurrency/stm.lux
@@ -0,0 +1,57 @@
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data [number]
+             (struct [list "" Functor])
+             text/format)
+       (concurrency stm
+                    [promise])
+       (codata function))
+  lux/test)
+
+(def: vars Int 5)
+(def: processes/vars Int 5)
+(def: iterations/processes Int 100)
+
+(test: "lux/concurrency/stm exports"
+  (let [_var (var 0)
+        changes (io;run (follow "test" _var))
+        tests (: (List (Test Int))
+                 (map (lambda [_]
+                        (let [_concurrency-var (var 0)]
+                          (from-promise (do promise;Monad
+                                          [_ (seqM @
+                                                   (map (lambda [_]
+                                                          (mapM @ (lambda [_] (commit (update inc _concurrency-var)))
+                                                                (list;range 1 iterations/processes)))
+                                                        (list;range 1 processes/vars)))]
+                                          (commit (read _concurrency-var))))))
+                      (list;range 1 vars)))]
+    (test-all (match+ 0 (commit (do Monad
+                                  [value (read _var)]
+                                  (wrap (#;Right value)))))
+              (match+ 5 (commit (do Monad
+                                  [_ (write 5 _var)
+                                   value (read _var)]
+                                  (wrap (#;Right value)))))
+              (match+ 5 (commit (do Monad
+                                  [value (read _var)]
+                                  (wrap (#;Right value)))))
+              (match+ 15 (commit (do Monad
+                                   [_ (update (* 3) _var)
+                                    value (read _var)]
+                                   (wrap (#;Right value)))))
+              (match+ 15 (commit (do Monad
+                                   [value (read _var)]
+                                   (wrap (#;Right value)))))
+              (match+ [5 15] (do promise;Monad
+                               [?c1+changes' changes
+                                #let [[c1 changes'] (default [-1 changes] ?c1+changes')]
+                                ?c2+changes' changes'
+                                #let [[c2 changes'] (default [-1 changes] ?c2+changes')]]
+                               (wrap (#;Right [c1 c2]))))
+              ## Temporarily commented-out due to type-checking bug in
+              ## compiler...
+              ## (match+ _ (seqM Monad tests))
+              )))
diff --git a/stdlib/test/test/lux/data/bit.lux b/stdlib/test/test/lux/data/bit.lux
new file mode 100644
index 000000000..e20027818
--- /dev/null
+++ b/stdlib/test/test/lux/data/bit.lux
@@ -0,0 +1,65 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control [monad])
+       (codata [io])
+       (data ["&" bit]
+             number)
+       (math ["R" random]))
+  lux/test)
+
+(def: width Nat +64)
+
+(test: "Bitwise operations."
+  [pattern R;nat
+   idx (:: @ map (%+ width) R;nat)]
+  (all (assert "" (and (<+ (&;count (&;set idx pattern))
+                           (&;count (&;clear idx pattern)))
+                       (<=+ (&;count pattern)
+                            (&;count (&;clear idx pattern)))
+                       (>=+ (&;count pattern)
+                            (&;count (&;set idx pattern)))
+
+                       (or (and (&;set? idx pattern)
+                                (not (&;set? idx (&;clear idx pattern))))
+                           (and (not (&;set? idx pattern))
+                                (&;set? idx (&;set idx pattern))))
+
+                       (or (and (&;set? idx pattern)
+                                (not (&;set? idx (&;flip idx pattern))))
+                           (and (not (&;set? idx pattern))
+                                (&;set? idx (&;flip idx pattern))))
+                       
+                       (=+ width
+                           (++ (&;count pattern)
+                               (&;count (&;~ pattern))))
+
+                       (=+ +0
+                           (&;& pattern
+                                (&;~ pattern)))
+                       (=+ (&;~ +0)
+                           (&;| pattern
+                                (&;~ pattern)))
+                       (=+ (&;~ +0)
+                           (&;^ pattern
+                                (&;~ pattern)))
+                       (=+ +0
+                           (&;^ pattern
+                                pattern))
+
+                       (|> pattern (&;rotate-left idx) (&;rotate-right idx) (=+ pattern))
+                       (|> pattern (&;rotate-right idx) (&;rotate-left idx) (=+ pattern))
+                       (|> pattern (&;rotate-left idx) (&;rotate-left (-+ idx width)) (=+ pattern))
+                       (|> pattern (&;rotate-right idx) (&;rotate-right (-+ idx width)) (=+ pattern))
+                       ))
+       
+       (assert "Shift right respect the sign of ints."
+               (let [value (nat-to-int pattern)]
+                 (if (< 0 value)
+                   (< 0 (&;>> idx value))
+                   (>= 0 (&;>> idx value)))))
+       ))
diff --git a/stdlib/test/test/lux/data/bool.lux b/stdlib/test/test/lux/data/bool.lux
new file mode 100644
index 000000000..218846e2e
--- /dev/null
+++ b/stdlib/test/test/lux/data/bool.lux
@@ -0,0 +1,38 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control [monad])
+       (codata [io])
+       (data bool)
+       (math ["R" random]))
+  lux/test)
+
+(test: "Boolean operations."
+  [value R;bool]
+  (assert "" (and (not (and value (not value)))
+                  (or value (not value))
+
+                  (not (:: Or@Monoid unit))
+                  (:: Or@Monoid append value (not value))
+                  (:: And@Monoid unit)
+                  (not (:: And@Monoid append value (not value)))
+                  
+                  (:: Eq = value (not (not value)))
+                  (not (:: Eq = value (not value)))
+
+                  (not (:: Eq = value ((complement id) value)))
+                  (:: Eq = value ((complement not) value))
+
+                  (case (|> value
+                            (:: Codec encode)
+                            (:: Codec decode))
+                    (#;Right dec-value)
+                    (:: Eq = value dec-value)
+
+                    (#;Left _)
+                    false)
+                  )))
diff --git a/stdlib/test/test/lux/data/char.lux b/stdlib/test/test/lux/data/char.lux
new file mode 100644
index 000000000..ab2e84d59
--- /dev/null
+++ b/stdlib/test/test/lux/data/char.lux
@@ -0,0 +1,47 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control [monad])
+       (codata [io])
+       (data char
+             [text])
+       (math ["R" random])
+       pipe
+       [host #- try])
+  lux/test)
+
+(test: "Char operations"
+  [value R;char]
+  (assert "" (and (:: Eq = value value)
+                  (|> value code char (:: Eq = value))
+                  (|> value
+                      (:: Codec encode)
+                      (:: Codec decode)
+                      (case> (#;Right dec-value)
+                             (:: Eq = value dec-value)
+
+                             (#;Left _)
+                             false))
+                  (|> value as-text
+                      (text;at +0) (default (undefined))
+                      (:: Eq = value))
+                  (|> value as-text text;upper-case
+                      (text;at +0) (default (undefined))
+                      (:: Ord <= value))
+                  (|> value as-text text;lower-case
+                      (text;at +0) (default (undefined))
+                      (:: Ord >= value))
+                  )))
+
+(test: "Special cases"
+  (all (assert "" (space? #" "))
+       (assert "" (space? #"\n"))
+       (assert "" (space? #"\t"))
+       (assert "" (space? #"\r"))
+       (assert "" (space? #"\f"))
+       (assert "" (not (space? #"a")))
+       ))
diff --git a/stdlib/test/test/lux/data/error.lux b/stdlib/test/test/lux/data/error.lux
new file mode 100644
index 000000000..a1d2cb6ff
--- /dev/null
+++ b/stdlib/test/test/lux/data/error.lux
@@ -0,0 +1,42 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data error))
+  lux/test)
+
+(test: "lux/data/error exports"
+  (all (match (#;Right 11)
+              (:: Functor map inc (: (Error Int)
+                                            (#;Right 10))))
+       (match (#;Left "YOLO")
+              (:: Functor map inc (: (Error Int)
+                                            (#;Left "YOLO"))))
+       
+       (match (#;Right 20)
+              (:: Applicative wrap 20))
+       (match (#;Right 11)
+              (let [(^open) Applicative]
+                (apply (wrap inc) (wrap 10))))
+       (match (#;Left "YOLO")
+              (let [(^open) Applicative]
+                (apply (wrap inc) (#;Left "YOLO"))))
+       
+       (match (#;Right 30)
+              (do Monad
+                [f (wrap +)
+                 a (wrap 10)
+                 b (wrap 20)]
+                (wrap (f a b))))
+       (match (#;Left "YOLO")
+              (do Monad
+                [f (wrap +)
+                 a (#;Left "YOLO")
+                 b (wrap 20)]
+                (wrap (f a b))))
+       ))
diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux
new file mode 100644
index 000000000..78b0b1a76
--- /dev/null
+++ b/stdlib/test/test/lux/data/format/json.lux
@@ -0,0 +1,314 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data [text "Text/" Monoid]
+             text/format
+             error
+             (format [json #* "JSON/" Eq Codec])
+             (struct [vector #+ vector]
+                     [dict]))
+       [compiler #+ with-gensyms]
+       (macro [ast]
+              [syntax #+ syntax:]
+              [poly #+ derived:])
+       [pipe]
+       test)
+  )
+
+## [Utils]
+(syntax: (reads-to-itself expr)
+  (with-gensyms [g!json g!parsed g!message]
+    (wrap (list (` (: (Test Unit)
+                      (let [(~ g!json) (~ expr)]
+                        (case (|> (~ g!json) JSON/encode JSON/decode)
+                          (#;Left (~ g!message))
+                          (fail (~ g!message))
+
+                          (#;Right (~ g!parsed))
+                          (if (JSON/= (~ g!json) (~ g!parsed))
+                            (~ (' (:: Monad wrap [])))
+                            (fail (format "Expression does not parse to itself: " (~ (ast;text (ast;ast-to-text expr)))
+                                          "\n\nWhich is: " (|> (~ g!json) JSON/encode)
+                                          "\n\nInstead, it parsed to: " (JSON/encode (~ g!parsed))))
+                            ))))
+                   )))))
+
+## [Tests]
+## (derived: (Codec ;Bool))
+## (derived: (Codec ;Int))
+## (derived: (Codec ;Real))
+## (derived: (Codec ;Char))
+## (derived: (Codec ;Text))
+
+## (type: Int-List (List Int))
+## (derived: (Codec ;;Int-List))
+
+## (type: Int-Maybe (Maybe Int))
+## (derived: (Codec ;;Int-Maybe))
+
+## (type: Triple [Bool Int Text])
+## (derived: (Codec ;;Triple))
+
+## (type: User
+##   {#alive? Bool
+##    #age Int
+##    #name Text})
+## (derived: (Codec ;;User))
+
+## (type: Options
+##   (#One Bool)
+##   (#Two Int)
+##   (#Three Text))
+## (derived: (Codec ;;Options))
+
+## (test: "Auto-generated codecs"
+##   (let% [ (do-template [  ]
+##                    [(match 
+##                            (|> 
+##                                (::  encode)
+##                                JSON/encode))
+##                     (match+ 
+##                             (should-pass (|> (JSON/decode )
+##                                              (pipe;%> Error/Monad
+##                                                       [(::  decode)]))))]
+
+##                    [true   "true"     Codec]
+##                    [123    "123.0"    Codec]
+##                    [123.45 "123.45"   Codec]
+##                    [#"a"   "\"a\""    Codec]
+##                    ["yolo" "\"yolo\"" Codec]
+
+##                    [(#;Cons 1 (#;Cons 2 (#;Cons 3 #;Nil))) "[1.0,2.0,3.0]" Codec]
+##                    [#;Nil "[]" Codec]
+##                    [(#;Some 1) "1.0" Codec]
+##                    [#;None "null" Codec]
+##                    [[false 456 "lol"] "[false,456.0,\"lol\"]" Codec]
+##                    [{#alive? true #age 25 #name "Eduardo Julian"}
+##                     "{\"alive?\":true,\"age\":25.0,\"name\":\"Eduardo Julian\"}"
+##                     Codec]
+##                    [(#One true) "[\"One\",true]" Codec]
+##                    [(#Two 123) "[\"Two\",123.0]" Codec]
+##                    [(#Three "yolo") "[\"Three\",\"yolo\"]" Codec]
+##                    )]
+##     (test-all 
+##               )))
+
+(test: "Basics"
+  (test-all (match #json;Null
+                   null)
+
+            (match (#json;Boolean true)
+                   (gen-boolean true))
+
+            (match (#json;Boolean false)
+                   (gen-boolean false))
+
+            (match (#json;Number 123.45)
+                   (gen-number 123.45))
+
+            (match (#json;String "YOLO")
+                   (gen-string "YOLO"))
+
+            ## (match (^ (#json;Array (list (#json;Boolean true) (#json;Number 123.45) (#json;String "YOLO"))))
+            ##        (json [(gen-boolean true) (gen-number 123.45) (gen-string "YOLO")]))
+
+            ## (match (^ (#json;Object (list ["yolo" (#json;Boolean true)]
+            ##                               ["lol" (#json;Number 123.45)])))
+            ##        (json {"yolo" (gen-boolean true)
+            ##                    "lol" (gen-number 123.45)}))
+
+            (match (#;Some (#json;Boolean true))
+                   (get "yolo" (json {"yolo" true
+                                      "lol" 123.45})))
+
+            (match (#;Left _)
+                   (get "yolo" (json {})))
+
+            ## (match (^ (#;Some (#json;Object (list ["lol" (#json;Number 123.45)]
+            ##                                       ["yolo" (#json;Boolean true)]))))
+            ##        (|> (json {"yolo" (gen-boolean true)})
+            ##            (set "lol" (gen-number 123.45))))
+
+            (match (#;Right true)
+                   (get-boolean "value" (json {"value" true})))
+
+            (match (#;Right 123.45)
+                   (get-number "value" (json {"value" 123.45})))
+
+            (match (#;Right "YOLO")
+                   (get-string "value" (json {"value" "YOLO"})))
+
+            ## (match (^ (#;Right (list (#json;Boolean true) (#json;Number 123.45) (#json;String "YOLO"))))
+            ##        (get-array "value" (json {"value" (json [(gen-boolean true)
+            ##                                                           (gen-number 123.45)
+            ##                                                           (gen-string "YOLO")])})))
+
+            ## (match (^ (#;Right (list ["yolo" (#json;Boolean true)]
+            ##                          ["lol" (#json;Number 123.45)])))
+            ##        (get-object "value" (json {"value" (json {"yolo" (gen-boolean true)
+            ##                                                            "lol" (gen-number 123.45)})})))
+
+            (match (#;Left _)
+                   (get-array "value" (json {})))
+
+            (match (#;Left _)
+                   (get-array "value" (gen-boolean true)))
+            ))
+
+(test: "Encoding"
+  (test-all (match "null"
+                   (JSON/encode (json #null)))
+
+            (match "123.0"
+                   (JSON/encode (json 123)))
+
+            (match "123.46"
+                   (JSON/encode (json 123.46)))
+
+            (match "true"
+                   (JSON/encode (json true)))
+
+            (match "false"
+                   (JSON/encode (json false)))
+
+            (match "\"YOLO\""
+                   (JSON/encode (json "YOLO")))
+
+            (match "[null,123.46,true,\"YOLO\",[\"nyan\",\"cat\"]]"
+                   (JSON/encode (json [#null 123.46 true "YOLO" ["nyan" "cat"]])))
+
+            (match "{\"foo\":\"bar\",\"baz\":null,\"quux\":[\"nyan\",{\"cat\":\"meme\"}]}"
+                   (JSON/encode (json {"foo" "bar"
+                                       "baz" #null
+                                       "quux" ["nyan" {"cat" "meme"}]})))
+            ))
+
+(test: "Decoding"
+  (test-all (reads-to-itself (json #null))
+            (reads-to-itself (json 123))
+            (reads-to-itself (json 123.46))
+            (reads-to-itself (json true))
+            (reads-to-itself (json false))
+            (reads-to-itself (json "\tY\"OLO\n"))
+            (reads-to-itself (json [#null 123.46 true "YOLO" ["nyan" "cat"]]))
+            (reads-to-itself (json {"foo" "bar"
+                                    "baz" #null
+                                    "quux" ["nyan" {"cat" "meme"}]}))
+            ))
+
+(test: "Parser"
+  (test-all (should-pass (run unit
+                              (json #null)))
+            (should-fail (run unit
+                              (json 123)))
+
+            (match+ 123.45
+                    (should-pass (run real
+                                      (json 123.45))))
+            (should-fail (run real
+                              (json #null)))
+
+            (match+ 123
+                    (should-pass (run int
+                                      (json 123))))
+            (should-fail (run int
+                              (json #null)))
+
+            (match+ true
+                    (should-pass (run bool
+                                      (json true))))
+            (should-fail (run bool
+                              (json 123)))
+
+            (match+ "YOLO"
+                    (should-pass (run text
+                                      (json "YOLO"))))
+            (should-fail (run text
+                              (json 123)))
+
+            (match+ (^ (list "YOLO" "LOL" "MEME"))
+                    (should-pass (run (array text)
+                                      (json ["YOLO" "LOL" "MEME"]))))
+            (should-fail (run (array text)
+                              (json 123)))
+
+            (match+ "LOL"
+                    (should-pass (run (at +1 text)
+                                      (json ["YOLO" "LOL" "MEME"]))))
+            (should-fail (run (array text)
+                              (json 123)))
+
+            (match+ "MEME"
+                    (should-pass (run (field "baz" text)
+                                      (json {"foo" "YOLO"
+                                             "bar" "LOL"
+                                             "baz" "MEME"}))))
+            (should-fail (run (field "baz" text)
+                              (json 123)))
+
+            (match+ (#json;Number 123.0)
+                    (should-pass (run any
+                                      (json 123))))
+
+            (match+ ["YOLO" "MEME"]
+                    (should-pass (run (seq (field "foo" text)
+                                           (field "baz" text))
+                                      (json {"foo" "YOLO"
+                                             "bar" "LOL"
+                                             "baz" "MEME"}))))
+            (should-fail (run (seq (field "foo" text)
+                                   (field "baz" text))
+                              (json {"foo" "YOLO"
+                                     "bar" "LOL"})))
+
+            (match+ (#;Left "YOLO")
+                    (should-pass (run (alt (field "foo" text)
+                                           (field "baz" text))
+                                      (json {"foo" "YOLO"
+                                             "bar" "LOL"
+                                             "baz" "MEME"}))))
+            (match+ (#;Right "MEME")
+                    (should-pass (run (alt (field "fool" text)
+                                           (field "baz" text))
+                                      (json {"foo" "YOLO"
+                                             "bar" "LOL"
+                                             "baz" "MEME"}))))
+            (should-fail (run (alt (field "fool" text)
+                                   (field "baz" text))
+                              (json {"foo" "YOLO"
+                                     "bar" "LOL"})))
+
+            (match+ "YOLO"
+                    (should-pass (run (either (field "foo" text)
+                                              (field "baz" text))
+                                      (json {"foo" "YOLO"
+                                             "bar" "LOL"
+                                             "baz" "MEME"}))))
+            (match+ "MEME"
+                    (should-pass (run (either (field "fool" text)
+                                              (field "baz" text))
+                                      (json {"foo" "YOLO"
+                                             "bar" "LOL"
+                                             "baz" "MEME"}))))
+            (should-fail (run (either (field "fool" text)
+                                      (field "baz" text))
+                              (json {"foo" "YOLO"
+                                     "bar" "LOL"})))
+
+            (match+ (#;Some "YOLO")
+                    (should-pass (run (opt (field "foo" text))
+                                      (json {"foo" "YOLO"
+                                             "bar" "LOL"
+                                             "baz" "MEME"}))))
+            (match+ #;None
+                    (should-pass (run (opt (field "fool" text))
+                                      (json {"foo" "YOLO"
+                                             "bar" "LOL"
+                                             "baz" "MEME"}))))
+            ))
diff --git a/stdlib/test/test/lux/data/ident.lux b/stdlib/test/test/lux/data/ident.lux
new file mode 100644
index 000000000..8cb85175f
--- /dev/null
+++ b/stdlib/test/test/lux/data/ident.lux
@@ -0,0 +1,53 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data ["&" ident]
+             [text "Text/" Eq])
+       (math ["R" random])
+       pipe)
+  lux/test)
+
+(test: "Idents"
+  [## First Ident
+   sizeM1 (|> R;nat (:: @ map (%+ +100)))
+   sizeN1 (|> R;nat (:: @ map (%+ +100)))
+   module1 (R;text sizeM1)
+   name1 (R;text sizeN1)
+   #let [ident1 [module1 name1]]
+   ## Second Ident
+   sizeM2 (|> R;nat (:: @ map (%+ +100)))
+   sizeN2 (|> R;nat (:: @ map (%+ +100)))
+   module2 (R;text sizeM2)
+   name2 (R;text sizeN2)
+   #let [ident2 [module2 name2]]
+   #let [(^open "&/") &;Eq
+         (^open "&/") &;Codec]]
+  (all (assert "Can get the module & name parts of an ident."
+               (and (== module1 (&;module ident1))
+                    (== name1 (&;name ident1))))
+
+       (assert "Can compare idents for equality."
+               (and (&/= ident1 ident1)
+                    (if (&/= ident1 ident2)
+                      (and (Text/= module1 module2)
+                           (Text/= name1 name2))
+                      (or (not (Text/= module1 module2))
+                          (not (Text/= name1 name2))))))
+
+       (assert "Can encode idents as text."
+               (|> ident1
+                   &/encode &/decode
+                   (case> (#;Right dec-ident) (&/= ident1 dec-ident)
+                          _ false)))
+
+       (assert "Encoding an ident without a module component results in text equal to the name of the ident."
+               (if (text;empty? module1)
+                 (Text/= name1 (&/encode ident1))
+                 true))
+       ))
diff --git a/stdlib/test/test/lux/data/identity.lux b/stdlib/test/test/lux/data/identity.lux
new file mode 100644
index 000000000..f492a801e
--- /dev/null
+++ b/stdlib/test/test/lux/data/identity.lux
@@ -0,0 +1,36 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad
+                comonad)
+       (data identity
+             [text "Text/" Monoid]))
+  lux/test)
+
+(test: "lux/data/identity exports"
+  (all (match "yololol" (:: Functor map (Text/append "yolo") "lol"))
+       
+       (match "yolo" (:: Applicative wrap "yolo"))
+       (match "yololol" (let [(^open) Applicative]
+                          (apply (wrap (Text/append "yolo")) (wrap "lol"))))
+       
+       (match "yololol"
+              (do Monad
+                [f (wrap Text/append)
+                 a (wrap "yolo")
+                 b (wrap "lol")]
+                (wrap (f a b))))
+       
+       (match "yololol" (:: CoMonad unwrap "yololol"))
+       (match "yololol"
+              (be CoMonad
+                [f Text/append
+                 a "yolo"
+                 b "lol"]
+                (f a b)))
+       ))
diff --git a/stdlib/test/test/lux/data/log.lux b/stdlib/test/test/lux/data/log.lux
new file mode 100644
index 000000000..c052a29da
--- /dev/null
+++ b/stdlib/test/test/lux/data/log.lux
@@ -0,0 +1,32 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data log
+             [text "Text/" Monoid]
+             [number])
+       (codata function))
+  lux/test)
+
+(test: "lux/data/log exports"
+  (all (match ["" 11]
+              (:: Functor map inc ["" 10]))
+       (match ["" 20]
+              (:: (Applicative text;Monoid) wrap 20))
+       (match ["" 30]
+              (let [(^open) (Applicative text;Monoid)]
+                (apply (wrap (+ 10)) (wrap 20))))
+       (match ["" 30]
+              (do (Monad text;Monoid)
+                [f (wrap +)
+                 a (wrap 10)
+                 b (wrap 20)]
+                (wrap (f a b))))
+       (match ["YOLO" []]
+              (log "YOLO"))
+       ))
diff --git a/stdlib/test/test/lux/data/maybe.lux b/stdlib/test/test/lux/data/maybe.lux
new file mode 100644
index 000000000..bd44593d7
--- /dev/null
+++ b/stdlib/test/test/lux/data/maybe.lux
@@ -0,0 +1,49 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data maybe
+             [text "Text/" Monoid]
+             [number]))
+  lux/test)
+
+(test: "lux/data/maybe exports"
+  (all (match #;None (:: Monoid unit))
+       (match (#;Some "yolo") (:: Monoid append (#;Some "yolo") (#;Some "lol")))
+       (match (#;Some "yolo") (:: Monoid append (#;Some "yolo") #;None))
+       (match (#;Some "lol") (:: Monoid append #;None (#;Some "lol")))
+       (match #;None (: (Maybe Text) (:: Monoid append #;None #;None)))
+       
+       (match #;None (:: Functor map (Text/append "yolo") #;None))
+       (match (#;Some "yololol") (:: Functor map (Text/append "yolo") (#;Some "lol")))
+       
+       (match (#;Some "yolo") (:: Applicative wrap "yolo"))
+       (match (#;Some "yololol")
+              (let [(^open) Applicative]
+                (apply (wrap (Text/append "yolo")) (wrap "lol"))))
+       
+       (match (#;Some "yololol")
+              (do Monad
+                [f (wrap Text/append)
+                 a (wrap "yolo")
+                 b (wrap "lol")]
+                (wrap (f a b))))
+
+       (match true (:: (Eq text;Eq) =
+                       (: (Maybe Text) #;None)
+                       (: (Maybe Text) #;None)))
+       (match true (:: (Eq text;Eq) =
+                       (#;Some "yolo")
+                       (#;Some "yolo")))
+       (match false (:: (Eq text;Eq) =
+                        (#;Some "yolo")
+                        (#;Some "lol")))
+       (match false (:: (Eq text;Eq) =
+                        (#;Some "yolo")
+                        (: (Maybe Text) #;None)))
+       ))
diff --git a/stdlib/test/test/lux/data/number.lux b/stdlib/test/test/lux/data/number.lux
new file mode 100644
index 000000000..adefb480a
--- /dev/null
+++ b/stdlib/test/test/lux/data/number.lux
@@ -0,0 +1,135 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data number
+             [text "Text/" Monoid]
+             text/format)
+       (math ["R" random])
+       pipe)
+  lux/test)
+
+(do-template [category rand-gen  ]
+  [(test: (format "[" category "] " "Eq & Ord")
+     [x rand-gen
+      y rand-gen]
+     (assert "" (and (::  = x x)
+                     (or (::  = x y)
+                         (::  < y x)
+                         (::  > y x)))))]
+
+  ["Nat"  R;nat  Eq  Ord]
+  ["Int"  R;int  Eq  Ord]
+  ["Real" R;real Eq Ord]
+  ["Frac" R;frac Eq Ord]
+  )
+
+(do-template [category rand-gen ]
+  [(test: (format "[" category "] " "Number")
+     [x rand-gen]
+     (assert "" (let [(^open) ]
+                  (and (>= x (abs x))
+                       (<= x (negate (abs x)))
+                       (= x (* (signum x)
+                               (abs x)))))))]
+
+  ["Nat"  R;nat  Number]
+  ["Int"  R;int  Number]
+  ["Real" R;real Number]
+  )
+
+(do-template [category rand-gen  ]
+  [(test: (format "[" category "] " "Enum")
+     [x rand-gen]
+     (assert "" (let [(^open) ]
+                  (and (> x
+                          (::  succ x))
+                       (< x
+                          (::  pred x))
+                       
+                       (= x
+                          (|> x (::  pred) (::  succ)))
+                       (= x
+                          (|> x (::  succ) (::  pred)))
+                       ))))]
+
+  ["Nat"  R;nat Enum Number]
+  ["Int"  R;int Enum Number]
+  )
+
+(do-template [category rand-gen  ]
+  [(test: (format "[" category "] " "Bounded")
+     [x rand-gen]
+     (assert "" (let [(^open) ]
+                  (and (<= x (::  bottom))
+                       (>= x (::  top))
+                       ))))]
+
+  ["Nat"  R;nat  Number  Bounded]
+  ["Int"  R;int  Number  Bounded]
+  ["Real" R;real Number Bounded]
+  )
+
+(do-template [category rand-gen   ]
+  [(test: (format "[" category "] " "Monoid")
+     [x (:: @ map (|>. (::  abs) ) rand-gen)]
+     (assert "" (let [(^open) 
+                      (^open) ]
+                  (and (= x (append unit x))
+                       (= x (append x unit))
+                       (= unit (append unit unit))
+                       (>= x (append x x))))))]
+
+  ["Nat/Add"  R;nat  Number  Add@Monoid  (;%+ +1000)]
+  ["Nat/Mul"  R;nat  Number  Mul@Monoid  (;%+ +1000)]
+  ["Nat/Min"  R;nat  Number  Min@Monoid  (;%+ +1000)]
+  ["Nat/Max"  R;nat  Number  Max@Monoid  (;%+ +1000)]
+  ["Int/Add"  R;int  Number  Add@Monoid  (;% 1000)]
+  ["Int/Mul"  R;int  Number  Mul@Monoid  (;% 1000)]
+  ["Int/Min"  R;int  Number  Min@Monoid  (;% 1000)]
+  ["Int/Max"  R;int  Number  Max@Monoid  (;% 1000)]
+  ["Real/Add" R;real Number Add@Monoid (;%. 1000.0)]
+  ["Real/Mul" R;real Number Mul@Monoid (;%. 1000.0)]
+  ["Real/Min" R;real Number Min@Monoid (;%. 1000.0)]
+  ["Real/Max" R;real Number Max@Monoid (;%. 1000.0)]
+  )
+
+(do-template [category rand-gen  ]
+  [(test: (format "[" category "] " "Codec")
+     [x rand-gen]
+     (assert "" (|> x
+                    (::  encode)
+                    (::  decode)
+                    (case> (#;Right x')
+                           (::  = x x')
+
+                           (#;Left _)
+                           false))))]
+
+  ["Nat"  R;nat  Number  Codec]
+  ["Int"  R;int  Number  Codec]
+  ["Real" R;real Number Codec]
+  ## ["Frac" R;frac Number Codec]
+  )
+
+(do-template [category rand-gen  ]
+  [(test: (format "[" category "] " "Alternative formats")
+     [x rand-gen]
+     (assert "" (|> x
+                    (::  encode)
+                    (::  decode)
+                    (case> (#;Right x')
+                           (::  = x x')
+
+                           (#;Left _)
+                           false))))]
+
+  ["Nat/Binary" R;nat  Number  Binary@Codec]
+  ["Nat/Octal"  R;nat  Number  Octal@Codec]
+  ["Nat/Hex"    R;nat  Number  Hex@Codec]
+  )
diff --git a/stdlib/test/test/lux/data/product.lux b/stdlib/test/test/lux/data/product.lux
new file mode 100644
index 000000000..51c23e47d
--- /dev/null
+++ b/stdlib/test/test/lux/data/product.lux
@@ -0,0 +1,20 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data product
+             [text "Text/" Monoid]
+             [number])
+       (codata function))
+  lux/test)
+
+(test: "Product operations"
+  (all (match 1 (left [1 2]))
+       (match 2 (right [1 2]))
+       (match [2 1] (swap [1 2]))
+       ))
diff --git a/stdlib/test/test/lux/data/struct/array.lux b/stdlib/test/test/lux/data/struct/array.lux
new file mode 100644
index 000000000..171631bd9
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/array.lux
@@ -0,0 +1,130 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control [monad])
+       (codata [io])
+       (data (struct ["&" array]
+                     [list])
+             [number])
+       (math ["R" random])
+       pipe)
+  lux/test)
+
+(def: bounded-size
+  (R;Random Nat)
+  (|> R;nat
+      (:: R;Monad map (|>. (%+ +100) (++ +1)))))
+
+(test: "Arrays and their copies"
+  [size bounded-size
+   original (R;array size R;nat)
+   #let [clone (&;clone original)
+         copy (: (&;Array Nat)
+                 (&;new size))
+         manual-copy (: (&;Array Nat)
+                        (&;new size))]]
+  (all (assert "Size function must correctly return size of array."
+               (=+ size (&;size original)))
+       (assert "Cloning an array should yield and identical array, but not the same one."
+               (and (:: (&;Eq number;Eq) = original clone)
+                    (not (== original clone))))
+       (assert "Full-range manual copies should give the same result as cloning."
+               (exec (&;copy size +0 original +0 copy)
+                 (and (:: (&;Eq number;Eq) = original copy)
+                      (not (== original copy)))))
+       (assert "Array folding should go over all values."
+               (exec (:: &;Fold fold
+                         (lambda [x idx]
+                           (exec (&;put idx x manual-copy)
+                             (inc+ idx)))
+                         +0
+                         original)
+                 (:: (&;Eq number;Eq) = original manual-copy)))
+       (assert "Transformations between (full) arrays and lists shouldn't cause lose or change any values."
+               (|> original
+                   &;to-list &;from-list
+                   (:: (&;Eq number;Eq) = original)))
+       ))
+
+(test: "Array mutation"
+  [size bounded-size
+   idx (:: @ map (%+ size) R;nat)
+   array (|> (R;array size R;nat)
+             (R;filter (|>. &;to-list (list;any? odd?+))))
+   #let [value (default (undefined)
+                 (&;get idx array))]]
+  (all (assert "Shouldn't be able to find a value in an unoccupied cell."
+               (case (&;get idx (&;remove idx array))
+                 (#;Some _) false
+                 #;None     true))
+       (assert "You should be able to access values put into the array."
+               (case (&;get idx (&;put idx value array))
+                 (#;Some value') (=+ value' value)
+                 #;None          false))
+       (assert "All cells should be occupied on a full array."
+               (and (=+ size (&;occupied array))
+                    (=+ +0 (&;vacant array))))
+       (assert "Filtering mutates the array to remove invalid values."
+               (exec (&;filter even?+ array)
+                 (and (<+ size (&;occupied array))
+                      (>+ +0 (&;vacant array))
+                      (=+ size (++ (&;occupied array)
+                                   (&;vacant array))))))
+       ))
+
+(test: "Finding values."
+  [size bounded-size
+   array (|> (R;array size R;nat)
+             (R;filter (|>. &;to-list (list;any? even?+))))]
+  (all (assert "Can find values inside arrays."
+               (|> (&;find even?+ array)
+                   (case> (#;Some _) true
+                          #;None     false)))
+       (assert "Can find values inside arrays (with access to indices)."
+               (|> (&;find+ (lambda [idx n]
+                              (and (even?+ n)
+                                   (<+ size idx)))
+                            array)
+                   (case> (#;Some _) true
+                          #;None     false)))))
+
+(test: "Functor"
+  [size bounded-size
+   array (R;array size R;nat)]
+  (let [(^open) &;Functor
+        (^open) (&;Eq number;Eq)]
+    (all (assert "Functor shouldn't alter original array."
+                 (let [copy (map id array)]
+                   (and (= array copy)
+                        (not (== array copy)))))
+         (assert "Functor should go over all available array elements."
+                 (let [there (map inc+ array)
+                       back-again (map dec+ there)]
+                   (and (not (= array there))
+                        (= array back-again)))))))
+
+(test: "Monoid"
+  [sizeL bounded-size
+   sizeR bounded-size
+   left (R;array sizeL R;nat)
+   right (R;array sizeR R;nat)
+   #let [(^open) &;Monoid
+         (^open) (&;Eq number;Eq)
+         fusion (append left right)]]
+  (all (assert "Appending two arrays should produce a new one twice as large."
+               (=+ (++ sizeL sizeR) (&;size fusion)))
+       (assert "First elements of fused array should equal the first array."
+               (|> (: (&;Array Nat)
+                      (&;new sizeL))
+                   (&;copy sizeL +0 fusion +0)
+                   (= left)))
+       (assert "Last elements of fused array should equal the second array."
+               (|> (: (&;Array Nat)
+                      (&;new sizeR))
+                   (&;copy sizeR sizeL fusion +0)
+                   (= right)))
+       ))
diff --git a/stdlib/test/test/lux/data/struct/dict.lux b/stdlib/test/test/lux/data/struct/dict.lux
new file mode 100644
index 000000000..06b9550aa
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/dict.lux
@@ -0,0 +1,136 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad
+                [eq])
+       (data [text "Text/" Monoid]
+             text/format
+             [number]
+             [char]
+             (struct ["&" dict]
+                     [list "List/" Fold Functor]))
+       (codata function)
+       (math ["R" random])
+       pipe)
+  lux/test)
+
+(test: "Dictionaries."
+  [#let [capped-nat (:: R;Monad map (%+ +100) R;nat)]
+   size capped-nat
+   dict (R;dict char;Hash size R;char capped-nat)
+   non-key (|> R;char
+               (R;filter (lambda [key] (not (&;contains? key dict)))))
+   test-val (|> R;nat
+                (R;filter (lambda [val] (not (list;member? number;Eq (&;values dict) val)))))]
+  (all (assert "Size function should correctly represent Dict size."
+               (=+ size (&;size dict)))
+       
+       (assert "Dicts of size 0 should be considered empty."
+               (if (=+ +0 size)
+                 (&;empty? dict)
+                 (not (&;empty? dict))))
+       
+       (assert "The functions 'entries', 'keys' and 'values' should be synchronized."
+               (:: (list;Eq (eq;conj char;Eq number;Eq)) =
+                   (&;entries dict)
+                   (list;zip2 (&;keys dict)
+                              (&;values dict))))
+       
+       (assert "Dict should be able to recognize it's own keys."
+               (list;every? (lambda [key] (&;contains? key dict))
+                            (&;keys dict)))
+       
+       (assert "Should be able to get every key."
+               (list;every? (lambda [key] (case (&;get key dict)
+                                       (#;Some _) true
+                                       _          false))
+                            (&;keys dict)))
+       
+       (assert "Shouldn't be able to access non-existant keys."
+               (case (&;get non-key dict)
+                 (#;Some _) false
+                 _          true))
+       
+       (assert "Should be able to put and then get a value."
+               (case (&;get non-key (&;put non-key test-val dict))
+                 (#;Some v) (=+ test-val v)
+                 _          true))
+       
+       (assert "Should be able to put~ and then get a value."
+               (case (&;get non-key (&;put~ non-key test-val dict))
+                 (#;Some v) (=+ test-val v)
+                 _          true))
+       
+       (assert "Shouldn't be able to put~ an existing key."
+               (or (=+ +0 size)
+                   (let [first-key (|> dict &;keys list;head (default (undefined)))]
+                     (case (&;get first-key (&;put~ first-key test-val dict))
+                       (#;Some v) (not (=+ test-val v))
+                       _          true))))
+       
+       (assert "Removing a key should make it's value inaccessible."
+               (let [base (&;put non-key test-val dict)]
+                 (and (&;contains? non-key base)
+                      (not (&;contains? non-key (&;remove non-key base))))))
+       
+       (assert "Should be possible to update values via their keys."
+               (let [base (&;put non-key test-val dict)
+                     updt (&;update non-key inc+ base)]
+                 (case [(&;get non-key base) (&;get non-key updt)]
+                   [(#;Some x) (#;Some y)]
+                   (=+ (inc+ x) y)
+
+                   _
+                   false)))
+       
+       (assert "Additions and removals to a Dict should affect its size."
+               (let [plus (&;put non-key test-val dict)
+                     base (&;remove non-key plus)]
+                 (and (=+ (inc+ (&;size dict)) (&;size plus))
+                      (=+ (dec+ (&;size plus)) (&;size base)))))
+
+       (assert "A Dict should equal itself & going to<->from lists shouldn't change that."
+               (let [(^open) (&;Eq number;Eq)]
+                 (and (= dict dict)
+                      (|> dict &;entries (&;from-list char;Hash) (= dict)))))
+
+       (assert "Merging a Dict to itself changes nothing."
+               (let [(^open) (&;Eq number;Eq)]
+                 (= dict (&;merge dict dict))))
+
+       (assert "If you merge, and the second dict has overlapping keys, it should overwrite yours."
+               (let [dict' (|> dict &;entries
+                               (List/map (lambda [[k v]] [k (inc+ v)]))
+                               (&;from-list char;Hash))
+                     (^open) (&;Eq number;Eq)]
+                 (= dict' (&;merge dict' dict))))
+
+       (assert "Can merge values in such a way that they become combined."
+               (list;every? (lambda [[x x*2]] (=+ (*+ +2 x) x*2))
+                            (list;zip2 (&;values dict)
+                                       (&;values (&;merge-with ++ dict dict)))))
+
+       (assert "Should be able to select subset of keys from dict."
+               (|> dict
+                   (&;put non-key test-val)
+                   (&;select (list non-key))
+                   &;size
+                   (=+ +1)))
+
+       (assert "Should be able to re-bind existing values to different keys."
+               (or (=+ +0 size)
+                   (let [first-key (|> dict &;keys list;head (default (undefined)))
+                         rebound (&;re-bind first-key non-key dict)]
+                     (and (=+ (&;size dict) (&;size rebound))
+                          (&;contains? non-key rebound)
+                          (not (&;contains? first-key rebound))
+                          (=+ (default (undefined)
+                                (&;get first-key dict))
+                              (default (undefined)
+                                (&;get non-key rebound)))))))
+       ))
diff --git a/stdlib/test/test/lux/data/struct/list.lux b/stdlib/test/test/lux/data/struct/list.lux
new file mode 100644
index 000000000..6baf13c6c
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/list.lux
@@ -0,0 +1,191 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data (struct ["&" list])
+             [text "Text/" Monoid]
+             [number]
+             [bool]
+             [product])
+       (math ["R" random])
+       pipe)
+  lux/test)
+
+(def: bounded-size
+  (R;Random Nat)
+  (|> R;nat
+      (:: R;Monad map (|>. (%+ +100) (++ +10)))))
+
+(test: "Lists"
+  [size bounded-size
+   idx (:: @ map (%+ size) R;nat)
+   sample (R;list size R;nat)
+   other-size bounded-size
+   other-sample (R;list other-size R;nat)
+   separator R;nat
+   #let [(^open) (&;Eq number;Eq)
+         (^open "&/") &;Functor]]
+  (all (assert "The size function should correctly portray the size of the list."
+               (=+ size (&;size sample)))
+
+       (assert "The repeat function should produce as many elements as asked of it."
+               (=+ size (&;size (&;repeat size []))))
+
+       (assert "Reversing a list does not change it's size."
+               (=+ (&;size sample)
+                   (&;size (&;reverse sample))))
+       
+       (assert "Reversing a list twice results in the original list."
+               (= sample
+                  (&;reverse (&;reverse sample))))
+
+       (assert "Filtering by a predicate and its complement should result in a number of elements equal to the original list."
+               (and (=+ (&;size sample)
+                        (++ (&;size (&;filter even?+ sample))
+                            (&;size (&;filter (bool;complement even?+) sample))))
+                    (let [[plus minus] (&;partition even?+ sample)]
+                      (=+ (&;size sample)
+                          (++ (&;size plus)
+                              (&;size minus))))))
+
+       (assert "If every element in a list satisfies a predicate, there can't be any that satisfy its complement."
+               (if (&;every? even?+ sample)
+                 (and (not (&;any? (bool;complement even?+) sample))
+                      (&;empty? (&;filter (bool;complement even?+) sample)))
+                 (&;any? (bool;complement even?+) sample)))
+
+       (assert "Any element of the list can be considered it's member."
+               (let [elem (default (undefined)
+                            (&;at idx sample))]
+                 (&;member? number;Eq sample elem)))
+
+       (assert "Appending the head and the tail should yield the original list."
+               (let [head (default (undefined)
+                            (&;head sample))
+                     tail (default (undefined)
+                            (&;tail sample))]
+                 (= sample
+                    (#;Cons head tail))))
+
+       (assert "Appending the inits and the last should yield the original list."
+               (let [(^open) &;Monoid
+                     inits (default (undefined)
+                             (&;inits sample))
+                     last (default (undefined)
+                            (&;last sample))]
+                 (= sample
+                    (append inits (list last)))))
+
+       (assert "Functor should go over every element of the list."
+               (let [(^open) &;Functor
+                     there (map inc+ sample)
+                     back-again (map dec+ there)]
+                 (and (not (= sample there))
+                      (= sample back-again))))
+
+       (assert "Splitting a list into chunks and re-appending them should yield the original list."
+               (let [(^open) &;Monoid
+                     [left right] (&;split idx sample)
+                     [left' right'] (&;split-with even?+ sample)]
+                 (and (= sample
+                         (append left right))
+                      (= sample
+                         (append left' right'))
+                      (= sample
+                         (append (&;take idx sample)
+                                 (&;drop idx sample)))
+                      (= sample
+                         (append (&;take-while even?+ sample)
+                                 (&;drop-while even?+ sample)))
+                      )))
+
+       (assert "Segmenting the list in pairs should yield as many elements as N/2."
+               (=+ (/+ +2 size)
+                   (&;size (&;as-pairs sample))))
+
+       (assert "Sorting a list shouldn't change it's size."
+               (=+ (&;size sample)
+                   (&;size (&;sort <+ sample))))
+
+       (assert "Sorting a list with one order should yield the reverse of sorting it with the opposite order."
+               (= (&;sort <+ sample)
+                  (&;reverse (&;sort >+ sample))))
+
+       (assert "If you zip 2 lists, the result's size will be that of the smaller list."
+               (=+ (&;size (&;zip2 sample other-sample))
+                   (min+ (&;size sample) (&;size other-sample))))
+       
+       (assert "I can pair-up elements of a list in order."
+               (let [(^open) &;Functor
+                     zipped (&;zip2 sample other-sample)
+                     num-zipper (&;size zipped)]
+                 (and (|> zipped (map product;left) (= (&;take num-zipper sample)))
+                      (|> zipped (map product;right) (= (&;take num-zipper other-sample))))))
+       
+       (assert "You can generate indices for any size, and they will be in ascending order."
+               (let [(^open) &;Functor
+                     indices (&;indices size)]
+                 (and (=+ size (&;size indices))
+                      (= indices
+                         (&;sort <+ indices))
+                      (&;every? (=+ (dec+ size))
+                                (&;zip2-with ++
+                                             indices
+                                             (&;sort >+ indices)))
+                      )))
+
+       (assert "The 'interpose' function places a value between every member of a list."
+               (let [(^open) &;Functor
+                     sample+ (&;interpose separator sample)]
+                 (and (=+ (|> size (*+ +2) dec+)
+                          (&;size sample+))
+                      (|> sample+ &;as-pairs (map product;right) (&;every? (=+ separator))))))
+
+       (assert "List append is a monoid."
+               (let [(^open) &;Monoid]
+                 (and (= sample (append unit sample))
+                      (= sample (append sample unit))
+                      (let [[left right] (&;split size (append sample other-sample))]
+                        (and (= sample left)
+                             (= other-sample right))))))
+
+       (assert "Applicative allows you to create singleton lists, and apply lists of functions to lists of values."
+               (let [(^open) &;Applicative]
+                 (and (= (list separator) (wrap separator))
+                      (= (map inc+ sample)
+                         (apply (wrap inc+) sample)))))
+
+       (assert "List concatenation is a monad."
+               (let [(^open) &;Monad
+                     (^open) &;Monoid]
+                 (= (append sample other-sample)
+                    (join (list sample other-sample)))))
+
+       (assert "You can find any value that satisfies some criterium, if such values exist in the list."
+               (case (&;find even?+ sample)
+                 (#;Some found)
+                 (and (even?+ found)
+                      (&;any? even?+ sample)
+                      (not (&;every? (bool;complement even?+) sample)))
+
+                 #;None
+                 (and (not (&;any? even?+ sample))
+                      (&;every? (bool;complement even?+) sample))))
+
+       (assert "You can iteratively construct a list, generating values until you're done."
+               (= (&;range+ +0 (dec+ size))
+                  (&;iterate (lambda [n] (if (<+ size n) (#;Some (inc+ n)) #;None))
+                             +0)))
+
+       (assert "Can enumerate all elements in a list."
+               (let [enum-sample (&;enumerate sample)]
+                 (and (= (&;indices (&;size enum-sample))
+                         (&/map product;left enum-sample))
+                      (= sample
+                         (&/map product;right enum-sample)))))
+       ))
diff --git a/stdlib/test/test/lux/data/struct/queue.lux b/stdlib/test/test/lux/data/struct/queue.lux
new file mode 100644
index 000000000..895929ab4
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/queue.lux
@@ -0,0 +1,54 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data (struct ["&" queue])
+             [number])
+       (math ["R" random])
+       pipe)
+  lux/test)
+
+(test: "Queues"
+  [size (:: @ map (%+ +100) R;nat)
+   sample (R;queue size R;nat)
+   non-member (|> R;nat
+                  (R;filter (. not (&;enqueued? number;Eq sample))))]
+  (all (assert "I can query the size of a queue (and empty queues have size 0)."
+               (if (=+ +0 size)
+                 (&;empty? sample)
+                 (=+ size (&;size sample))))
+
+       (assert "Enqueueing and dequeing affects the size of queues."
+               (and (=+ (inc+ size) (&;size (&;enqueue non-member sample)))
+                    (or (&;empty? sample)
+                        (=+ (dec+ size) (&;size (&;dequeue sample))))
+                    (=+ size (&;size (&;dequeue (&;enqueue non-member sample))))))
+
+       (assert "Transforming to/from list can't change the queue."
+               (let [(^open "&/") (&;Eq number;Eq)]
+                 (|> sample
+                     &;to-list &;from-list
+                     (&/= sample))))
+
+       (assert "I can always peek at a non-empty queue."
+               (case (&;peek sample)
+                 #;None     (&;empty? sample)
+                 (#;Some _) true))
+
+       (assert "I can query whether an element belongs to a queue."
+               (and (not (&;enqueued? number;Eq sample non-member))
+                    (&;enqueued? number;Eq (&;enqueue non-member sample)
+                                 non-member)
+                    (case (&;peek sample)
+                      #;None
+                      (&;empty? sample)
+                      
+                      (#;Some first)
+                      (and (&;enqueued? number;Eq sample first)
+                           (not (&;enqueued? number;Eq (&;dequeue sample) first))))))
+       ))
diff --git a/stdlib/test/test/lux/data/struct/set.lux b/stdlib/test/test/lux/data/struct/set.lux
new file mode 100644
index 000000000..3725e7f93
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/set.lux
@@ -0,0 +1,67 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data (struct ["&" set]
+                     [list "" Fold])
+             [number])
+       (math ["R" random])
+       pipe)
+  lux/test)
+
+(def: gen-nat
+  (R;Random Nat)
+  (|> R;nat
+      (:: R;Monad map (%+ +100))))
+
+(test: "Sets"
+  [sizeL gen-nat
+   sizeR gen-nat
+   setL (R;set number;Hash sizeL gen-nat)
+   setR (R;set number;Hash sizeR gen-nat)
+   non-member (|> gen-nat
+                  (R;filter (. not (&;member? setL))))
+   #let [(^open "&/") &;Eq]]
+  (all (assert "I can query the size of a set."
+               (and (=+ sizeL (&;size setL))
+                    (=+ sizeR (&;size setR))))
+
+       (assert "Converting sets to/from lists can't change their values."
+               (|> setL
+                   &;to-list (&;from-list number;Hash)
+                   (&/= setL)))
+
+       (assert "Every set is a sub-set of the union of itself with another."
+               (let [setLR (&;union setL setR)]
+                 (and (&;sub? setLR setL)
+                      (&;sub? setLR setR))))
+
+       (assert "Every set is a super-set of the intersection of itself with another."
+               (let [setLR (&;intersection setL setR)]
+                 (and (&;super? setLR setL)
+                      (&;super? setLR setR))))
+
+       (assert "Union with the empty set leaves a set unchanged."
+               (&/= setL
+                    (&;union (&;new number;Hash)
+                             setL)))
+
+       (assert "Intersection with the empty set results in the empty set."
+               (let [empty-set (&;new number;Hash)]
+                 (&/= empty-set
+                      (&;intersection empty-set setL))))
+
+       (assert "After substracting a set A from another B, no member of A can be a member of B."
+               (let [sub (&;difference setR setL)]
+                 (not (list;any? (&;member? setL) (&;to-list setR)))))
+
+       (assert "Every member of a set must be identifiable."
+               (and (not (&;member? setL non-member))
+                    (&;member? (&;add non-member setL) non-member)
+                    (not (&;member? (&;remove non-member (&;add non-member setL)) non-member))))
+       ))
diff --git a/stdlib/test/test/lux/data/struct/stack.lux b/stdlib/test/test/lux/data/struct/stack.lux
new file mode 100644
index 000000000..dc3bb1e89
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/stack.lux
@@ -0,0 +1,47 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data (struct ["&" stack]
+                     [list "" Fold])
+             [number])
+       (math ["R" random])
+       pipe)
+  lux/test)
+
+(def: gen-nat
+  (R;Random Nat)
+  (|> R;nat
+      (:: R;Monad map (%+ +100))))
+
+(test: "Stacks"
+  [size gen-nat
+   sample (R;stack size gen-nat)
+   new-top gen-nat]
+  (all (assert "Can query the size of a stack."
+               (=+ size (&;size sample)))
+
+       (assert "Can peek inside non-empty stacks."
+               (case (&;peek sample)
+                 #;None     (&;empty? sample)
+                 (#;Some _) (not (&;empty? sample))))
+
+       (assert "Popping empty stacks doesn't change anything.
+                But, if they're non-empty, the top of the stack is removed."
+               (let [sample' (&;pop sample)]
+                 (or (=+ (&;size sample) (inc+ (&;size sample')))
+                     (and (&;empty? sample) (&;empty? sample')))
+                 ))
+
+       (assert "Pushing onto a stack always increases it by 1, adding a new value at the top."
+               (and (== sample
+                        (&;pop (&;push new-top sample)))
+                    (=+ (inc+ (&;size sample)) (&;size (&;push new-top sample)))
+                    (|> (&;push new-top sample) &;peek (default (undefined))
+                        (== new-top))))
+       ))
diff --git a/stdlib/test/test/lux/data/struct/tree.lux b/stdlib/test/test/lux/data/struct/tree.lux
new file mode 100644
index 000000000..0595ca7b3
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/tree.lux
@@ -0,0 +1,39 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data (struct ["&" tree]
+                     [list "List/" Monad])
+             [number])
+       (math ["R" random])
+       pipe)
+  lux/test)
+
+(def: gen-nat
+  (R;Random Nat)
+  (|> R;nat
+      (:: R;Monad map (%+ +100))))
+
+(test: "Trees"
+  [leaf (:: @ map &;leaf R;nat)
+   branchS gen-nat
+   branchV R;nat
+   branchC (R;list branchS R;nat)
+   #let [branch (&;branch branchV (List/map &;leaf branchC))]
+   #let [(^open "&/") (&;Eq number;Eq)
+         (^open "List/") (list;Eq number;Eq)]]
+  (all (assert "Can compare trees for equality."
+               (and (&/= leaf leaf)
+                    (&/= branch branch)
+                    (not (&/= leaf branch))
+                    (not (&/= leaf (&;branch branchV (List/map &;leaf (list;reverse branchC)))))))
+
+       (assert "Can flatten a tree to get all the nodes as a flat tree."
+               (List/= (list& branchV branchC)
+                       (&;flatten branch)))
+       ))
diff --git a/stdlib/test/test/lux/data/struct/vector.lux b/stdlib/test/test/lux/data/struct/vector.lux
new file mode 100644
index 000000000..87f8fa4cb
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/vector.lux
@@ -0,0 +1,84 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data (struct ["&" vector]
+                     [list "List/" Fold Functor])
+             [text "Text/" Monoid]
+             text/format
+             [number])
+       (codata function)
+       (math ["R" random])
+       pipe)
+  lux/test)
+
+(test: "Vectors"
+  [size (|> R;nat (:: @ map (%+ +100)))
+   idx (|> R;nat (:: @ map (%+ size)))
+   sample (R;vector size R;nat)
+   other-sample (R;vector size R;nat)
+   non-member (|> R;nat (R;filter (. not (&;member? number;Eq sample))))
+   #let [(^open "&/") (&;Eq number;Eq)
+         (^open "&/") &;Monad
+         (^open "&/") &;Fold
+         (^open "&/") &;Monoid]]
+  (all (assert "Can query size of vector."
+               (if (&;empty? sample)
+                 (and (=+ +0 size)
+                      (=+ +0 (&;size sample)))
+                 (=+ size (&;size sample))))
+
+       (assert "Can add and remove elements to vectors."
+               (and (=+ (inc+ size)
+                        (&;size (&;add non-member sample)))
+                    (=+ (dec+ size)
+                        (&;size (&;pop sample)))))
+
+       (assert "Can put and get elements into vectors."
+               (|> sample
+                   (&;put idx non-member)
+                   (&;at idx)
+                   (default (undefined))
+                   (== non-member)))
+
+       (assert "Can update elements of vectors."
+               (|> sample
+                   (&;put idx non-member)
+                   (&;update idx inc+)
+                   (&;at idx)
+                   (default (undefined))
+                   (=+ (inc+ non-member))))
+
+       (assert "Can safely transform to/from lists."
+               (|> sample
+                   &;to-list &;from-list
+                   (&/= sample)))
+
+       (assert "Can identify members of a vector."
+               (and (not (&;member? number;Eq sample non-member))
+                    (&;member? number;Eq (&;add non-member sample) non-member)))
+
+       (assert "Can fold over elements of vector."
+               (=+ (List/fold ++ +0 (&;to-list sample))
+                   (&/fold ++ +0 sample)))
+       
+       (assert "Functor goes over every element."
+               (let [there (&/map inc+ sample)
+                     back-again (&/map dec+ there)]
+                 (and (not (&/= sample there))
+                      (&/= sample back-again))))
+
+       (assert "Applicative allows you to create singleton vectors, and apply vectors of functions to vectors of values."
+               (and (&/= (&;vector non-member) (&/wrap non-member))
+                    (&/= (&/map inc+ sample)
+                         (&/apply (&/wrap inc+) sample))))
+
+       (assert "Vector concatenation is a monad."
+               (&/= (&/append sample other-sample)
+                    (&/join (&;vector sample other-sample))))
+       ))
diff --git a/stdlib/test/test/lux/data/struct/zipper.lux b/stdlib/test/test/lux/data/struct/zipper.lux
new file mode 100644
index 000000000..a3bede88d
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/zipper.lux
@@ -0,0 +1,127 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data (struct ["&" zipper]
+                     [tree]
+                     [list "List/" Fold Functor])
+             [text "Text/" Monoid]
+             text/format
+             [number])
+       (codata function)
+       (math ["R" random])
+       pipe)
+  lux/test)
+
+(def: gen-tree
+  (R;Random (tree;Tree Nat))
+  (R;rec (lambda [gen-tree]
+           (do R;Monad
+             ## Each branch can have, at most, 1 child.
+             [size (|> R;nat (:: @ map (%+ +2)))]
+             (R;seq R;nat
+                    (R;list size gen-tree))))))
+
+(def: (to-end zipper)
+  (All [a] (-> (&;Zipper a) (&;Zipper a)))
+  (loop [zipper zipper]
+    (if (&;end? zipper)
+      zipper
+      (recur (&;next zipper)))))
+
+(test: "Zippers"
+  [sample gen-tree
+   new-val R;nat
+   pre-val R;nat
+   post-val R;nat
+   #let [(^open "Tree/") (tree;Eq number;Eq)
+         (^open "List/") (list;Eq number;Eq)]]
+  (all (assert "Trees can be converted to/from zippers."
+               (|> sample
+                   &;from-tree &;to-tree
+                   (Tree/= sample)))
+
+       (assert "Creating a zipper gives you a root node."
+               (|> sample &;from-tree &;root?))
+       
+       (assert "Can move down inside branches. Can move up from lower nodes."
+               (let [zipper (&;from-tree sample)]
+                 (if (&;branch? zipper)
+                   (let [child (|> zipper &;down)]
+                     (and (not (Tree/= sample (&;to-tree child)))
+                          (|> child &;parent (default (undefined)) (== zipper))
+                          (|> child &;up (== zipper))
+                          (|> child &;root (== zipper))))
+                   (and (&;leaf? zipper)
+                        (|> zipper (&;prepend-child new-val) &;branch?)))))
+
+       (assert "Can prepend and append children."
+               (let [zipper (&;from-tree sample)]
+                 (if (&;branch? zipper)
+                   (let [mid-val (|> zipper &;down &;value)
+                         zipper (|> zipper
+                                    (&;prepend-child pre-val)
+                                    (&;append-child post-val))]
+                     (and (|> zipper &;down &;value (== pre-val))
+                          (|> zipper &;down &;right &;value (== mid-val))
+                          (|> zipper &;down &;right &;right &;value (== post-val))
+                          (|> zipper &;down &;rightmost &;leftmost &;value (== pre-val))
+                          (|> zipper &;down &;right &;left &;value (== mid-val))
+                          (|> zipper &;down &;rightmost &;value (== post-val))))
+                   true)))
+
+       (assert "Can insert children around a node (unless it's root)."
+               (let [zipper (&;from-tree sample)]
+                 (if (&;branch? zipper)
+                   (let [mid-val (|> zipper &;down &;value)
+                         zipper (|> zipper
+                                    &;down
+                                    (&;insert-left pre-val)
+                                    (default (undefined))
+                                    (&;insert-right post-val)
+                                    (default (undefined))
+                                    &;up)]
+                     (and (|> zipper &;down &;value (== pre-val))
+                          (|> zipper &;down &;right &;value (== mid-val))
+                          (|> zipper &;down &;right &;right &;value (== post-val))
+                          (|> zipper &;down &;rightmost &;leftmost &;value (== pre-val))
+                          (|> zipper &;down &;right &;left &;value (== mid-val))
+                          (|> zipper &;down &;rightmost &;value (== post-val))))
+                   (and (|> zipper (&;insert-left pre-val) (case> (#;Some _) false
+                                                                  #;None     true))
+                        (|> zipper (&;insert-right post-val) (case> (#;Some _) false
+                                                                    #;None     true))))))
+       
+       (assert "Can set and update the value of a node."
+               (|> sample &;from-tree (&;set new-val) &;value (=+ new-val)))
+
+       (assert "Zipper traversal follows the outline of the tree depth-first."
+               (List/= (tree;flatten sample)
+                       (loop [zipper (&;from-tree sample)]
+                         (if (&;end? zipper)
+                           (list)
+                           (#;Cons (&;value zipper)
+                                   (recur (&;next zipper)))))))
+
+       (assert "Backwards zipper traversal yield reverse tree flatten."
+               (List/= (list;reverse (tree;flatten sample))
+                       (loop [zipper (to-end (&;from-tree sample))]
+                         (if (&;root? zipper)
+                           (list)
+                           (#;Cons (&;value zipper)
+                                   (recur (&;prev zipper)))))))
+
+       (assert "Can remove nodes (except root nodes)."
+               (let [zipper (&;from-tree sample)]
+                 (if (&;branch? zipper)
+                   (and (|> zipper &;down &;root? not)
+                        (|> zipper &;down &;remove (case> #;None false
+                                                          (#;Some node) (&;root? node))))
+                   (|> zipper &;remove (case> #;None     true
+                                              (#;Some _) false)))))
+       ))
diff --git a/stdlib/test/test/lux/data/sum.lux b/stdlib/test/test/lux/data/sum.lux
new file mode 100644
index 000000000..a23eeec00
--- /dev/null
+++ b/stdlib/test/test/lux/data/sum.lux
@@ -0,0 +1,32 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data sum
+             [text "Text/" Monoid]
+             [number])
+       (codata function))
+  lux/test)
+
+(test: "Sum operations"
+  (all (match (+0 1) (left 1))
+       (match (+1 2) (right 2))
+       (match (^ (list "0" "2"))
+              (lefts (: (List (| Text Text))
+                        (list (+0 "0") (+1 "1") (+0 "2")))))
+       (match (^ (list "1"))
+              (rights (: (List (| Text Text))
+                         (list (+0 "0") (+1 "1") (+0 "2")))))
+       (match (^ [(list "0" "2") (list "1")])
+              (partition (: (List (| Text Text))
+                            (list (+0 "0") (+1 "1") (+0 "2")))))
+       (match 10
+              (either (lambda [_] 10) (lambda [_] 20) (: (| Text Text) (+0 ""))))
+       (match 20
+              (either (lambda [_] 10) (lambda [_] 20) (: (| Text Text) (+1 ""))))
+       ))
diff --git a/stdlib/test/test/lux/data/text.lux b/stdlib/test/test/lux/data/text.lux
new file mode 100644
index 000000000..640ae3f4c
--- /dev/null
+++ b/stdlib/test/test/lux/data/text.lux
@@ -0,0 +1,150 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data ["&" text]
+             [char]
+             text/format
+             [number]
+             (struct [list]))
+       (codata function)
+       (math ["R" random])
+       pipe)
+  lux/test)
+
+(test: "Size"
+  [size (:: @ map (%+ +100) R;nat)
+   sample (R;text size)]
+  (assert "" (or (and (=+ +0 size)
+                      (&;empty? sample))
+                 (=+ size (&;size sample)))))
+
+(def: bounded-size
+  (R;Random Nat)
+  (|> R;nat
+      (:: R;Monad map (|>. (%+ +100) (++ +1)))))
+
+(test: "Locations"
+  [size bounded-size
+   idx (:: @ map (%+ size) R;nat)
+   sample (R;text size)]
+  (assert "" (|> sample
+                 (&;at idx)
+                 (case> (^=> (#;Some char)
+                             {(char;as-text char) char'}
+                             {[(&;index-of char' sample)
+                               (&;last-index-of char' sample)
+                               (&;index-of' char' idx sample)
+                               (&;last-index-of' char' idx sample)]
+                              [(#;Some io) (#;Some lio)
+                               (#;Some io') (#;Some lio')]})
+                        (and (<=+ idx io)
+                             (>=+ idx lio)
+
+                             (=+ idx io')
+                             (>=+ idx lio')
+
+                             (&;contains? char' sample))
+
+                        _
+                        false
+                        ))
+          ))
+
+(test: "Text functions"
+  [sizeL bounded-size
+   sizeR bounded-size
+   sampleL (R;text sizeL)
+   sampleR (R;text sizeR)
+   #let [sample (&;concat (list sampleL sampleR))
+         fake-sample (&;join-with " " (list sampleL sampleR))
+         dup-sample (&;join-with "" (list sampleL sampleR))
+         enclosed-sample (&;enclose [sampleR sampleR] sampleL)
+         (^open) &;Eq]]
+  (assert "" (and (not (= sample fake-sample))
+                  (= sample dup-sample)
+                  (&;starts-with? sampleL sample)
+                  (&;ends-with? sampleR sample)
+                  (= enclosed-sample
+                     (&;enclose' sampleR sampleL))
+                  
+                  (|> (&;split sizeL sample)
+                      (case> (#;Right [_l _r])
+                             (and (= sampleL _l)
+                                  (= sampleR _r)
+                                  (= sample (&;concat (list _l _r))))
+
+                             _
+                             false))
+                  
+                  (|> [(&;sub +0 sizeL sample)
+                       (&;sub sizeL (&;size sample) sample)
+                       (&;sub' sizeL sample)
+                       (&;sub' +0 sample)]
+                      (case> [(#;Right _l) (#;Right _r) (#;Right _r') (#;Right _f)]
+                             (and (= sampleL _l)
+                                  (= sampleR _r)
+                                  (= _r _r')
+                                  (= sample _f))
+
+                             _
+                             false))
+                  )
+          ))
+
+(test: "More text functions"
+  [sizeS bounded-size
+   sizeP bounded-size
+   sizeL bounded-size
+   sep1 (R;text sizeS)
+   sep2 (R;text sizeS)
+   #let [part-gen (|> (R;text sizeP)
+                      (R;filter (. not (&;contains? sep1))))]
+   parts (R;list sizeL part-gen)
+   #let [sample1 (&;concat (list;interpose sep1 parts))
+         sample2 (&;concat (list;interpose sep2 parts))
+         (^open) &;Eq]]
+  (assert "" (and (=+ (list;size parts)
+                      (list;size (&;split-all-with sep1 sample1)))
+                  (= sample2
+                     (&;replace sep1 sep2 sample1))
+                  )))
+
+(test: "Other text functions"
+  (all (match "abc" (&;lower-case "ABC"))
+       (match "ABC" (&;upper-case "abc"))
+       (match "ABC" (&;trim " \tABC\n\r"))
+       ))
+
+(test: "Structures"
+  (all (assert "" (:: &;Ord < "bcd" "abc"))
+       (assert "" (not (:: &;Ord < "abc" "abc")))
+       (assert "" (not (:: &;Ord < "abc" "bcd")))
+       (assert "" (:: &;Ord <= "bcd" "abc"))
+       (assert "" (:: &;Ord <= "abc" "abc"))
+       (assert "" (not (:: &;Ord <= "abc" "bcd")))
+       (assert "" (:: &;Ord > "abc" "bcd"))
+       (assert "" (not (:: &;Ord > "abc" "abc")))
+       (assert "" (not (:: &;Ord > "bcd" "abc")))
+       (assert "" (:: &;Ord >= "abc" "bcd"))
+       (assert "" (:: &;Ord >= "abc" "abc"))
+       (assert "" (not (:: &;Ord >= "bcd" "abc")))
+       ))
+
+(test: "Codec"
+  [size bounded-size
+   sample (R;text size)
+   #let [(^open) &;Eq]]
+  (assert "" (|> sample
+                 (:: &;Codec encode)
+                 (:: &;Codec decode)
+                 (case> (#;Right decoded)
+                        (= sample decoded)
+
+                        _
+                        false))))
diff --git a/stdlib/test/test/lux/data/text/format.lux b/stdlib/test/test/lux/data/text/format.lux
new file mode 100644
index 000000000..cd15c8584
--- /dev/null
+++ b/stdlib/test/test/lux/data/text/format.lux
@@ -0,0 +1,22 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data text/format
+             [number])
+       (codata function))
+  lux/test)
+
+(test: "Formatters"
+  (all (match "true" (%b true))
+       (match "123" (%i 123))
+       (match "123.456" (%r 123.456))
+       (match "#\"t\"" (%c #"t"))
+       (match "\"YOLO\"" (%t "YOLO"))
+       (match "User-id: 123 -- Active: true" (format "User-id: " (%i 123) " -- Active: " (%b true)))
+       ))
diff --git a/stdlib/test/test/lux/host.lux b/stdlib/test/test/lux/host.lux
new file mode 100644
index 000000000..109d8dfed
--- /dev/null
+++ b/stdlib/test/test/lux/host.lux
@@ -0,0 +1,54 @@
+(;module:
+  lux
+  (lux (control monad)
+       (data text/format
+             [number]
+             [product])
+       (codata function
+               [io])
+       host)
+  lux/test)
+
+(jvm-import java.lang.Object
+  (new []))
+
+(jvm-import java.lang.String)
+
+(jvm-import (java.lang.Class a)
+  (getName [] String))
+
+(test: "lux/host exports"
+  (let% [ (do-template [  ]
+                           [(match  (|>   ))]
+
+                           [123   l2d d2l]
+                           [123   l2f f2l]
+                           [123   l2i i2l]
+                           [123.0 d2l l2d]
+                           [123.0 d2f f2d]
+                           [123.0 d2i i2d]
+                           )
+          (do-template [ ]
+                           [(match 123 (|> 123 l2i   i2l))]
+
+                           [i2c c2i]
+                           )]
+    (test-all (match "java.lang.Class" (Class.getName [] (class-for java.lang.Class)))
+              (match "java.lang.Class" (Class.getName [] (class-for Class)))
+              (match true (null? (: Object (null))))
+              (match false (null? (Object.new [])))
+              (match #;None (: (Maybe Object) (??? (null))))
+              (match (#;Some _) (: (Maybe Object) (??? (Object.new []))))
+              (match true (null? (!!! (: (Maybe Object) (??? (null))))))
+              (match false (null? (!!! (: (Maybe Object) (??? (Object.new []))))))
+              (match true (instance? Object (Object.new [])))
+              (match false (instance? String (Object.new [])))
+              (match 123 (synchronized (Object.new [])
+                           123))
+              (match +10 (array-length (array String +10)))
+              (match "YOLO" (let [array (array String +10)] 
+                              (exec (array-store +0 "YOLO" array)
+                                (array-load +0 array))))
+              
+              
+              )))
diff --git a/stdlib/test/test/lux/lexer.lux b/stdlib/test/test/lux/lexer.lux
new file mode 100644
index 000000000..d0b17fe4b
--- /dev/null
+++ b/stdlib/test/test/lux/lexer.lux
@@ -0,0 +1,133 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  [lux #- not]
+  (lux (control monad)
+       (codata [io])
+       (data error)
+       [test #- fail assert]
+       lexer))
+
+## [Tests]
+(test: "Lexer end works"
+  (test-all (should-pass (run end ""))
+            (should-fail (run end "YOLO"))))
+
+(test: "Simple text lexers"
+  (test-all (match (#;Right "YO")
+                   (run (this "YO") "YOLO"))
+            (should-fail (run (this "YO") "MEME"))))
+
+(test: "Char lexers"
+  (test-all (match (#;Right #"Y")
+                   (run (this-char #"Y") "YOLO"))
+            (should-fail (run (this-char #"Y") "MEME"))
+            (match (#;Right #"Y")
+                   (run (char-range #"X" #"Z") "YOLO"))
+            (should-fail (run (char-range #"X" #"Z") "MEME"))
+            (match (#;Right #"Y")
+                   (run upper "YOLO"))
+            (should-fail (run upper "meme"))
+            (match (#;Right #"y")
+                   (run lower "yolo"))
+            (should-fail (run lower "MEME"))
+            (match (#;Right #"1")
+                   (run digit "1"))
+            (should-fail (run digit " "))
+            (match (#;Right #"7")
+                   (run oct-digit "7"))
+            (should-fail (run oct-digit "8"))
+            (match (#;Right #"A")
+                   (run any "A"))
+            (should-fail (run any ""))))
+
+(test: "Combinators"
+  (test-all (match (#;Right [#"Y" #"O"])
+                   (run (seq any any) "YOLO"))
+            (should-fail (run (seq any any) "Y"))
+            (match+ (#;Left #"0")
+                    (should-pass (run (alt digit upper) "0")))
+            (match+ (#;Right #"A")
+                    (should-pass (run (alt digit upper) "A")))
+            (should-fail (run (alt digit upper) "a"))
+            (should-pass (run (not (alt digit upper)) "a"))
+            (should-fail (run (not (alt digit upper)) "A"))
+            (match (#;Right #"0")
+                   (run (either digit upper) "0"))
+            (match (#;Right #"A")
+                   (run (either digit upper) "A"))
+            (should-fail (run (either digit upper) "a"))
+            (match (#;Right #"A")
+                   (run alpha "A"))
+            (match (#;Right #"a")
+                   (run alpha "a"))
+            (should-fail (run alpha "1"))
+            (match (#;Right #"A")
+                   (run alpha-num "A"))
+            (match (#;Right #"a")
+                   (run alpha-num "a"))
+            (match (#;Right #"1")
+                   (run alpha-num "1"))
+            (should-fail (run alpha-num " "))
+            (match (#;Right #"1")
+                   (run hex-digit "1"))
+            (match (#;Right #"a")
+                   (run hex-digit "a"))
+            (match (#;Right #"A")
+                   (run hex-digit "A"))
+            (should-fail (run hex-digit " "))
+            (match (#;Right #" ")
+                   (run space " "))
+            (should-fail (run space "8"))
+            (match (#;Right #"C")
+                   (run (one-of "ABC") "C"))
+            (should-fail (run (one-of "ABC") "D"))
+            (match (#;Right #"D")
+                   (run (none-of "ABC") "D"))
+            (should-fail (run (none-of "ABC") "C"))
+            (match (#;Right #"D")
+                   (run (satisfies (lambda [c] true)) "D"))
+            (should-fail (run (satisfies (lambda [c] false)) "C"))
+            (match (#;Right "0123456789ABCDEF")
+                   (run (many' hex-digit) "0123456789ABCDEF yolo"))
+            (should-fail (run (many' hex-digit) "yolo"))
+            (match (#;Right "")
+                   (run (some' hex-digit) "yolo"))
+            ))
+
+(test: "Yet more combinators..."
+  (test-all (should-fail (run (fail "Well, it really SHOULD fail...") "yolo"))
+            (should-fail (run (assert false "Well, it really SHOULD fail...") "yolo"))
+            (should-pass (run (assert true "GO, GO, GO!") "yolo"))
+            (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+                   (run (many hex-digit) "0123456789ABCDEF yolo"))
+            (should-fail (run (many hex-digit) "yolo"))
+            (match (^ (#;Right (list)))
+                   (run (some hex-digit) "yolo"))
+            (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+                   (run (exactly +16 hex-digit) "0123456789ABCDEF yolo"))
+            (match (^ (#;Right (list #"0" #"1" #"2")))
+                   (run (exactly +3 hex-digit) "0123456789ABCDEF yolo"))
+            (should-fail (run (exactly +17 hex-digit) "0123456789ABCDEF yolo"))
+            (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+                   (run (at-most +16 hex-digit) "0123456789ABCDEF yolo"))
+            (match (^ (#;Right (list #"0" #"1" #"2")))
+                   (run (at-most +3 hex-digit) "0123456789ABCDEF yolo"))
+            (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+                   (run (at-most +17 hex-digit) "0123456789ABCDEF yolo"))
+            (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+                   (run (between +0 +16 hex-digit) "0123456789ABCDEF yolo"))
+            (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+                   (run (between +3 +16 hex-digit) "0123456789ABCDEF yolo"))
+            (should-fail (run (between +17 +100 hex-digit) "0123456789ABCDEF yolo"))
+            (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+                   (run (between +15 +20 hex-digit) "0123456789ABCDEF yolo"))
+            (match (#;Right (#;Some #"1")) (run (opt hex-digit) "123abc"))
+            (match (#;Right #;None) (run (opt hex-digit) "yolo"))
+            (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"a" #"b" #"c" #"d" #"e" #"f")))
+                   (run (sep-by space hex-digit) "0 1 2 3 4 5 6 7 8 9 a b c d e f YOLO"))
+            (match (#;Right "yolo") (run get-input "yolo"))
+            ))
diff --git a/stdlib/test/test/lux/macro/ast.lux b/stdlib/test/test/lux/macro/ast.lux
new file mode 100644
index 000000000..b06efce01
--- /dev/null
+++ b/stdlib/test/test/lux/macro/ast.lux
@@ -0,0 +1,31 @@
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data [text "Text/" Monoid]
+             [number])
+       (macro ast)
+       (codata function))
+  lux/test)
+
+(test: "lux/macro/ast exports"
+  (let% [ (do-template [  ]
+                   [(match  )
+                    (match  (ast-to-text ))
+                    (match true (:: Eq =  ))]
+
+                   [(bool true)                             "true"       [["" -1 -1] (#;BoolS true)]]
+                   [(bool false)                            "false"      [_ (#;BoolS false)]]
+                   [(int 123)                               "123"        [_ (#;IntS 123)]]
+                   [(real 123.0)                            "123.0"      [_ (#;RealS 123.0)]]
+                   [(char #"\n")                            "#\"\\n\""   [_ (#;CharS #"\n")]]
+                   [(text "\n")                             "\"\\n\""    [_ (#;TextS "\n")]]
+                   [(tag ["yolo" "lol"])                    "#yolo;lol"  [_ (#;TagS ["yolo" "lol"])]]
+                   [(symbol ["yolo" "lol"])                 "yolo;lol"   [_ (#;SymbolS ["yolo" "lol"])]]
+                   [(form (list (bool true) (int 123)))     "(true 123)" (^ [_ (#;FormS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])]
+                   [(tuple (list (bool true) (int 123)))    "[true 123]" (^ [_ (#;TupleS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])]
+                   [(record (list [(bool true) (int 123)])) "{true 123}" (^ [_ (#;RecordS (list [[_ (#;BoolS true)] [_ (#;IntS 123)]]))])]
+                   [(local-tag "lol")                       "#lol"       [_ (#;TagS ["" "lol"])]]
+                   [(local-symbol "lol")                    "lol"        [_ (#;SymbolS ["" "lol"])]]
+                   )]
+    (test-all )))
diff --git a/stdlib/test/test/lux/macro/syntax.lux b/stdlib/test/test/lux/macro/syntax.lux
new file mode 100644
index 000000000..99f8550c0
--- /dev/null
+++ b/stdlib/test/test/lux/macro/syntax.lux
@@ -0,0 +1,176 @@
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data [text "Text/" Monoid]
+             [number])
+       (macro [ast]
+              ["s" syntax #+ syntax: Syntax])
+       (codata function))
+  lux/test)
+
+(test: "lux/macro/syntax exports [Part 1]"
+  (let% [ (do-template [    ]
+                          [(match (#;Right [_ ])
+                                  (s;run (list )
+                                         ))
+                           (match (#;Right [_ true])
+                                  (s;run (list )
+                                         ( )))
+                           (match (#;Right [_ []])
+                                  (s;run (list )
+                                         ( )))]
+
+                          [true           (ast;bool true)             s;bool   s;bool?   s;bool!]
+                          [123            (ast;int 123)               s;int    s;int?    s;int!]
+                          [123.0          (ast;real 123.0)            s;real   s;real?   s;real!]
+                          [#"\n"          (ast;char #"\n")            s;char   s;char?   s;char!]
+                          ["\n"           (ast;text "\n")             s;text   s;text?   s;text!]
+                          [["yolo" "lol"] (ast;symbol ["yolo" "lol"]) s;symbol s;symbol? s;symbol!]
+                          [["yolo" "lol"] (ast;tag ["yolo" "lol"])    s;tag    s;tag?    s;tag!]
+                          )
+          (do-template [ ]
+                         [(match (#;Right [_ [true 123]])
+                                 (s;run (list ( (list (ast;bool true) (ast;int 123))))
+                                        ( (s;seq s;bool s;int))))
+                          (match (#;Right [_ true])
+                                 (s;run (list ( (list (ast;bool true))))
+                                        ( s;bool)))
+                          (match (#;Left _)
+                                 (s;run (list ( (list (ast;bool true) (ast;int 123))))
+                                        ( s;bool)))
+                          (match (#;Right [_ (#;Left true)])
+                                 (s;run (list ( (list (ast;bool true))))
+                                        ( (s;alt s;bool s;int))))
+                          (match (#;Right [_ (#;Right 123)])
+                                 (s;run (list ( (list (ast;int 123))))
+                                        ( (s;alt s;bool s;int))))
+                          (match (#;Left _)
+                                 (s;run (list ( (list (ast;real 123.0))))
+                                        ( (s;alt s;bool s;int))))]
+
+                         [s;form  ast;form]
+                         [s;tuple ast;tuple])]
+    (test-all (match (#;Right [_ [_ (#;BoolS true)]])
+                     (s;run (list (ast;bool true) (ast;int 123))
+                            s;any))
+              
+              (match (#;Right [_ []])
+                     (s;run (list (ast;bool true) (ast;int 123))
+                            (s;assert true "yolo")))
+              (match (#;Left _)
+                     (s;run (list (ast;bool true) (ast;int 123))
+                            (s;assert false "yolo")))
+              (match (#;Right [_ +123])
+                     (s;run (list (ast;nat +123))
+                            s;nat))
+              (match (#;Left _)
+                     (s;run (list (ast;int -123))
+                            s;nat))
+              (match (#;Right [_ "yolo"])
+                     (s;run (list (ast;local-symbol "yolo"))
+                            s;local-symbol))
+              (match (#;Left _)
+                     (s;run (list (ast;symbol ["yolo" "lol"]))
+                            s;local-symbol))
+              (match (#;Right [_ "yolo"])
+                     (s;run (list (ast;local-tag "yolo"))
+                            s;local-tag))
+              (match (#;Left _)
+                     (s;run (list (ast;tag ["yolo" "lol"]))
+                            s;local-tag))
+              
+              )))
+
+(test: "lux/macro/syntax exports [Part 2]"
+  (test-all (match (#;Right [_ [true 123]])
+                   (s;run (list (ast;record (list [(ast;bool true) (ast;int 123)])))
+                          (s;record (s;seq s;bool s;int))))
+            (match (#;Right [_ (#;Some +123)])
+                   (s;run (list (ast;nat +123))
+                          (s;opt s;nat)))
+            (match (#;Right [_ #;None])
+                   (s;run (list (ast;int -123))
+                          (s;opt s;nat)))
+            (match (^ (#;Right [_ (list +123 +456 +789)]))
+                   (s;run (list (ast;nat +123) (ast;nat +456) (ast;nat +789))
+                          (s;some s;nat)))
+            (match (^ (#;Right [_ (list)]))
+                   (s;run (list (ast;int -123))
+                          (s;some s;nat)))
+            (match (^ (#;Right [_ (list +123 +456 +789)]))
+                   (s;run (list (ast;nat +123) (ast;nat +456) (ast;nat +789))
+                          (s;many s;nat)))
+            (match (^ (#;Right [_ (list +123)]))
+                   (s;run (list (ast;nat +123))
+                          (s;many s;nat)))
+            (match (#;Left _)
+                   (s;run (list (ast;int -123))
+                          (s;many s;nat)))
+            (match (#;Right [_ 123])
+                   (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+                          (s;either s;pos-int s;int)))
+            (match (#;Right [_ -123])
+                   (s;run (list (ast;int -123) (ast;int 456) (ast;int 789))
+                          (s;either s;pos-int s;int)))
+            (match (#;Left _)
+                   (s;run (list (ast;bool true) (ast;int 456) (ast;int 789))
+                          (s;either s;pos-int s;int)))
+            (match (#;Right [_ true])
+                   (s;run (list)
+                          s;end?))
+            (match (#;Right [_ false])
+                   (s;run (list (ast;bool true))
+                          s;end?))
+            (match (#;Right [_ []])
+                   (s;run (list)
+                          s;end))
+            (match (#;Left _)
+                   (s;run (list (ast;bool true))
+                          s;end))
+            (match (^ (#;Right [_ (list 123 456 789)]))
+                   (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+                          (s;exactly +3 s;int)))
+            (match (^ (#;Right [_ (list 123 456)]))
+                   (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+                          (s;exactly +2 s;int)))
+            (match (#;Left _)
+                   (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+                          (s;exactly +4 s;int)))
+            (match (^ (#;Right [_ (list 123 456 789)]))
+                   (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+                          (s;at-least +3 s;int)))
+            (match (^ (#;Right [_ (list 123 456 789)]))
+                   (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+                          (s;at-least +2 s;int)))
+            (match (#;Left _)
+                   (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+                          (s;at-least +4 s;int)))
+            (match (^ (#;Right [_ (list 123 456 789)]))
+                   (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+                          (s;at-most +3 s;int)))
+            (match (^ (#;Right [_ (list 123 456)]))
+                   (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+                          (s;at-most +2 s;int)))
+            (match (^ (#;Right [_ (list 123 456 789)]))
+                   (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+                          (s;at-most +4 s;int)))
+            (match (^ (#;Right [_ (list 123 456 789)]))
+                   (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+                          (s;between +3 +10 s;int)))
+            (match (#;Left _)
+                   (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+                          (s;between +4 +10 s;int)))
+            (match (^ (#;Right [_ (list 123 456 789)]))
+                   (s;run (list (ast;int 123) (ast;text "YOLO") (ast;int 456) (ast;text "YOLO") (ast;int 789))
+                          (s;sep-by (s;text! "YOLO") s;int)))
+            (match (^ (#;Right [_ (list 123 456)]))
+                   (s;run (list (ast;int 123) (ast;text "YOLO") (ast;int 456) (ast;int 789))
+                          (s;sep-by (s;text! "YOLO") s;int)))
+            (match (#;Left _)
+                   (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+                          (s;not s;int)))
+            (match (#;Right [_ []])
+                   (s;run (list (ast;bool true) (ast;int 456) (ast;int 789))
+                          (s;not s;int)))
+            ))
diff --git a/stdlib/test/test/lux/math.lux b/stdlib/test/test/lux/math.lux
new file mode 100644
index 000000000..3d5e053f7
--- /dev/null
+++ b/stdlib/test/test/lux/math.lux
@@ -0,0 +1,45 @@
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data [text "Text/" Monoid]
+             text/format
+             [number]
+             (struct [list "List/" Fold Functor])
+             [product])
+       (codata function)
+       math)
+  lux/test)
+
+(test: "lux/math exports"
+  (test-all (match 1.0 (cos 0.0))
+            (match -1.0 (cos (/. 2.0 tau)))
+            ## (match 0.0 (cos (/. 4.0 tau)))
+            ## (match 0.0 (cos (*. (/. 4.0 3.0) tau)))
+
+            (match 1.0 (sin (/. 4.0 tau)))
+            (match -1.0 (sin (*. (/. 4.0 3.0) tau)))
+            ## (match 0.0 (sin 0.0))
+            ## (match 0.0 (sin (/. 2.0 tau)))
+
+            (match 4 (ceil 3.75))
+            (match 3 (floor 3.75))
+            (match 4 (round 3.75))
+            (match 3 (round 3.25))
+
+            (match 3.0 (cbrt 27.0))
+            (match 4.0 (sqrt 16.0))
+
+            (match 90.0 (degrees (/. 4.0 tau)))
+            (match true (=. tau (radians (degrees tau))))
+
+            (match 9 (gcd 450 27))
+            (match 40 (lcm 10 8))
+
+            (match 27 (infix 27))
+            (match 9 (infix [27 gcd 450]))
+            (match 9 (infix [(* 3 9) gcd 450]))
+            (match true (infix [#and 27 < 450 < 2000]))
+            (match true (infix [#and 27 < 450 > 200]))
+            (match true (infix [[27 < 450] and [200 < 2000]]))
+            ))
diff --git a/stdlib/test/test/lux/pipe.lux b/stdlib/test/test/lux/pipe.lux
new file mode 100644
index 000000000..a601bbf98
--- /dev/null
+++ b/stdlib/test/test/lux/pipe.lux
@@ -0,0 +1,47 @@
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data text/format
+             [number]
+             [product]
+             identity)
+       (codata function)
+       pipe)
+  lux/test)
+
+(test: "lux/pipe exports"
+  (test-all (match 1 (|> 20
+                         (* 3)
+                         (+ 4)
+                         (_> 0 inc)))
+            (match 10 (|> 5
+                          (@> [(+ @ @)])))
+            (match 15 (|> 5
+                          (?> [even?] [(* 2)]
+                              [odd?] [(* 3)]
+                              [(_> -1)])))
+            (match 15 (|> 5
+                          (?> [even?] [(* 2)]
+                              [odd?] [(* 3)])))
+            (match 10 (|> 1
+                          (!> [(< 10)]
+                              [inc])))
+            (match 20 (|> 5
+                          (%> Monad
+                              [(* 3)]
+                              [(+ 4)]
+                              [inc])))
+            (match "five" (|> 5
+                              (case> 0 "zero"
+                                     1 "one"
+                                     2 "two"
+                                     3 "three"
+                                     4 "four"
+                                     5 "five"
+                                     6 "six"
+                                     7 "seven"
+                                     8 "eight"
+                                     9 "nine"
+                                     _ "???")))
+            ))
diff --git a/stdlib/test/test/lux/regex.lux b/stdlib/test/test/lux/regex.lux
new file mode 100644
index 000000000..66355bdca
--- /dev/null
+++ b/stdlib/test/test/lux/regex.lux
@@ -0,0 +1,200 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data error
+             [product])
+       [compiler]
+       (macro [ast]
+              ["s" syntax #+ syntax:])
+       test
+       [lexer]
+       regex))
+
+(syntax: (should-regex {veredict (s;alt s;bool s;any)} {regex s;text} {input s;text})
+  (case veredict
+    (+0 ?)
+    (if ?
+      (wrap (list (` (match+ (~ (ast;text input))
+                             (should-pass (lexer;run (regex (~ (ast;text regex)))
+                                                     (~ (ast;text input))))))))
+      (wrap (list (` (should-fail (lexer;run (regex (~ (ast;text regex)))
+                                             (~ (ast;text input))))))))
+
+    (+1 result)
+    (wrap (list (` (match+ (~ result)
+                           (should-pass (lexer;run (regex (~ (ast;text regex)))
+                                                   (~ (ast;text input))))))))))
+
+## [Tests]
+(test: "Regular Expressions [Basics]"
+  (test-all (should-regex true "a" "a")
+            (should-regex false "a" ".")
+            (should-regex true "\\." ".")
+            (should-regex false "\\." "a")
+            ))
+
+(test: "Regular Expressions [System character classes]"
+  (test-all (should-regex true "." "a")
+
+            (should-regex true "\\d" "0")
+            (should-regex false "\\d" "m")
+            (should-regex true "\\D" "m")
+            (should-regex false "\\D" "0")
+
+            (should-regex true "\\s" " ")
+            (should-regex false "\\s" "m")
+            (should-regex true "\\S" "m")
+            (should-regex false "\\S" " ")
+
+            (should-regex true "\\w" "_")
+            (should-regex false "\\w" "^")
+            (should-regex true "\\W" ".")
+            (should-regex false "\\W" "a")
+
+            (should-regex true "\\p{Lower}" "m")
+            (should-regex false "\\p{Lower}" "M")
+
+            (should-regex true "\\p{Upper}" "M")
+            (should-regex false "\\p{Upper}" "m")
+
+            (should-regex true "\\p{Alpha}" "M")
+            (should-regex false "\\p{Alpha}" "0")
+
+            (should-regex true "\\p{Digit}" "1")
+            (should-regex false "\\p{Digit}" "n")
+
+            (should-regex true "\\p{Alnum}" "1")
+            (should-regex false "\\p{Alnum}" ".")
+
+            (should-regex true "\\p{Space}" " ")
+            (should-regex false "\\p{Space}" ".")
+
+            (should-regex true "\\p{HexDigit}" "a")
+            (should-regex false "\\p{HexDigit}" ".")
+
+            (should-regex true "\\p{OctDigit}" "6")
+            (should-regex false "\\p{OctDigit}" ".")
+
+            (should-regex true "\\p{Blank}" "\t")
+            (should-regex false "\\p{Blank}" ".")
+
+            (should-regex true "\\p{ASCII}" "\t")
+            (should-regex false "\\p{ASCII}" "\u1234")
+
+            (should-regex true "\\p{Contrl}" "\u0012")
+            (should-regex false "\\p{Contrl}" "a")
+
+            (should-regex true "\\p{Punct}" "@")
+            (should-regex false "\\p{Punct}" "a")
+
+            (should-regex true "\\p{Graph}" "@")
+            (should-regex false "\\p{Graph}" " ")
+
+            (should-regex true "\\p{Print}" "\u0020")
+            (should-regex false "\\p{Print}" "\u1234")
+            ))
+
+(test: "Regular Expressions [Custom character classes]"
+  (test-all (should-regex true "[abc]" "a")
+            (should-regex false "[abc]" "m")
+
+            (should-regex true "[a-z]" "a")
+            (should-regex true "[a-z]" "m")
+            (should-regex true "[a-z]" "z")
+
+            (should-regex true "[a-zA-Z]" "a")
+            (should-regex true "[a-zA-Z]" "m")
+            (should-regex true "[a-zA-Z]" "z")
+            (should-regex true "[a-zA-Z]" "A")
+            (should-regex true "[a-zA-Z]" "M")
+            (should-regex true "[a-zA-Z]" "Z")
+
+            (should-regex false "[^abc]" "a")
+            (should-regex true "[^abc]" "m")
+
+            (should-regex false "[^a-z]" "a")
+            (should-regex true "[^a-z]" "0")
+            (should-regex false "[^a-zA-Z]" "a")
+            (should-regex true "[^a-zA-Z]" "0")
+
+            (should-regex false "[a-z&&[def]]" "a")
+            (should-regex true "[a-z&&[def]]" "d")
+
+            (should-regex true "[a-z&&[^bc]]" "a")
+            (should-regex false "[a-z&&[^bc]]" "b")
+
+            (should-regex true "[a-z&&[^m-p]]" "a")
+            (should-regex false "[a-z&&[^m-p]]" "m")
+            (should-regex false "[a-z&&[^m-p]]" "p")
+            ))
+
+(test: "Regular Expressions [Reference]"
+  (test-all (let [number (regex "\\d+")]
+              (should-regex ["809-345-6789" "809" "345" "6789"] "(\\@)-(\\@)-(\\@)" "809-345-6789"))
+            ))
+
+(test: "Regular Expressions [Quantifiers]"
+  (test-all (should-regex "aa" "aa" "aa")
+
+            (should-regex "a" "a?" "a")
+            (should-regex "" "a?" "")
+            
+            (should-regex "aaa" "a*" "aaa")
+            (should-regex "" "a*" "")
+            
+            (should-regex "aaa" "a+" "aaa")
+            (should-regex "a" "a+" "a")
+            (should-regex false "a+" "")
+
+            (should-regex "aa" "a{2}" "aa")
+            (should-regex "a" "a{1}" "aa")
+            (should-regex false "a{3}" "aa")
+
+            (should-regex "aa" "a{1,}" "aa")
+            (should-regex "aa" "a{2,}" "aa")
+            (should-regex false "a{3,}" "aa")
+
+            (should-regex "a" "a{,1}" "aa")
+            (should-regex "aa" "a{,2}" "aa")
+            (should-regex "aa" "a{,3}" "aa")
+
+            (should-regex "a" "a{1,2}" "a")
+            (should-regex "aa" "a{1,2}" "aa")
+            (should-regex "aa" "a{1,2}" "aaa")
+            ))
+
+(test: "Regular Expressions [Groups]"
+  (test-all (should-regex ["abc" "b"] "a(.)c" "abc")
+            (should-regex ["abbbbbc" "bbbbb"] "a(b+)c" "abbbbbc")
+            (should-regex ["809-345-6789" "809" "345" "6789"] "(\\d{3})-(\\d{3})-(\\d{4})" "809-345-6789")
+            (should-regex ["809-345-6789" "809" "6789"] "(\\d{3})-(?:\\d{3})-(\\d{4})" "809-345-6789")
+            (should-regex ["809-809-6789" "809" "6789"] "(\\d{3})-\\0-(\\d{4})" "809-809-6789")
+            (should-regex ["809-809-6789" "809" "6789"] "(?\\d{3})-\\k-(\\d{4})" "809-809-6789")
+            (should-regex ["809-809-6789-6789" "809" "6789"] "(?\\d{3})-\\k-(\\d{4})-\\0" "809-809-6789-6789")
+
+            (should-regex ["809-345-6789" "809" ["345-6789" "345" "6789"]] "(\\d{3})-((\\d{3})-(\\d{4}))" "809-345-6789")
+            ))
+
+(test: "Regular Expressions [Alternation]"
+  (test-all (should-regex ["a" (+0 [])] "a|b" "a")
+            (should-regex ["b" (+1 [])] "a|b" "b")
+            (should-regex false "a|b" "c")
+
+            (should-regex ["abc" (+0 "b")] "a(.)c|b(.)d" "abc")
+            (should-regex ["bcd" (+1 "c")] "a(.)c|b(.)d" "bcd")
+            (should-regex false "a(.)c|b(.)d" "cde")
+
+            (should-regex ["abc" (+0 ["b" "c"])] "a(.)(.)|b(.)(.)" "abc")
+            (should-regex ["bcd" (+1 ["c" "d"])] "a(.)(.)|b(.)(.)" "bcd")
+            (should-regex false "a(.)(.)|b(.)(.)" "cde")
+
+            (should-regex ["809-345-6789" (+0 ["809" "345-6789" "345" "6789"])]
+                          "(\\d{3})-((\\d{3})-(\\d{4}))|b(.)d"
+                          "809-345-6789")
+            ))
diff --git a/stdlib/test/test/lux/type.lux b/stdlib/test/test/lux/type.lux
new file mode 100644
index 000000000..8fa871e70
--- /dev/null
+++ b/stdlib/test/test/lux/type.lux
@@ -0,0 +1,41 @@
+(;module:
+  lux
+  (lux (codata [io])
+       (control monad)
+       (data [text "Text/" Monoid]
+             [number])
+       type
+       (codata function))
+  lux/test)
+
+(test: "lux/type exports"
+  (let% [ (do-template []
+                      [(match true (:: Eq =  ))]
+
+                      [(#;HostT "java.util.List" (list Int))]
+                      [#;UnitT]
+                      [#;VoidT]
+                      [(#;VarT +123)]
+                      [(#;ExT +123)]
+                      [(#;BoundT +123)]
+                      [(#;LambdaT Bool Int)]
+                      [(#;AppT List Int)]
+                      [(#;NamedT ["" "Int-List"] (#;AppT List Int))]
+                      [(#;SumT Bool Int)]
+                      [(#;ProdT Bool Int)]
+                      [(#;UnivQ (list) (#;ProdT Bool (#;BoundT +1)))]
+                      [(#;ExQ (list) (#;ProdT Bool (#;BoundT +1)))]
+                      )]
+    (test-all 
+              (match (^=> (#;Some _type) (:: Eq = _type (#;ProdT Bool Int)))
+                     (apply-type (type (Meta Bool)) Int))
+              (match #;None (apply-type Text Bool))
+              (match true
+                     (:: Eq =
+                         (#;NamedT ["" "a"]
+                                   (#;ProdT Bool Int))
+                         (un-alias (#;NamedT ["" "c"]
+                                             (#;NamedT ["" "b"]
+                                                       (#;NamedT ["" "a"]
+                                                                 (#;ProdT Bool Int)))))))
+              )))
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
new file mode 100644
index 000000000..7b760c0f1
--- /dev/null
+++ b/stdlib/test/tests.lux
@@ -0,0 +1,84 @@
+##  Copyright (c) Eduardo Julian. All rights reserved.
+##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+##  If a copy of the MPL was not distributed with this file,
+##  You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+  lux
+  (lux (control monad)
+       (codata [io])
+       (concurrency [promise])
+       [cli #+ program:]
+       [test])
+  (test lux
+        (lux (data [bit]
+                   [bool]
+                   [char]
+                   [error]
+                   [ident]
+                   [identity]
+                   [log]
+                   [maybe]
+                   [number]
+                   [product]
+                   [sum]
+                   [text]
+                   [text/format]
+                   (struct [array]
+                           [dict]
+                           [list]
+                           [queue]
+                           [set]
+                           [stack]
+                           [tree]
+                           [vector]
+                           [zipper]
+                           )
+                   )
+             ## (codata ["_;" io]
+             ##         [env]
+             ##         [state]
+             ##         (struct [stream]))
+             ## (macro [ast]
+             ##        [syntax])
+             ## [type]
+             ## (concurrency ["_;" promise]
+             ##              [frp]
+             ##              [stm]
+             ##              [actor]
+             ##              )
+             ## [host]
+             ## ["_;" cli]
+             ## [math]
+             ## [pipe]
+             ## [lexer]
+             ## [regex]
+             ## (data (format [json]))
+             )
+        )
+  ## (lux ## (codata [cont])
+  ##      ## (data (struct [stack]
+  ##      ##               [tree]
+  ##      ##               [zipper])
+  ##      ##       (error exception))
+  ##      ## (concurrency [atom])
+  ##      ## [macro]
+  ##      ## (macro [template]
+  ##      ##        [poly]
+  ##      ##        (poly ["poly_;" eq]
+  ##      ##              ["poly_;" text-encoder]
+  ##      ##              ["poly_;" functor]))
+  ##      ## (math [ratio]
+  ##      ##       [complex]
+  ##      ##       [random])
+  ##      ## (type [check] [auto])
+  ##      ## (control [effect])
+  ##      ["_;" lexer]
+  ##      ["_;" regex]
+  ##      (data (format ["_;" json]))
+  ##      )
+  )
+
+## [Program]
+(program: args
+  (test;run))
diff --git a/test/test/lux/lexer.clj b/test/test/lux/lexer.clj
deleted file mode 100644
index 3bd45cb5f..000000000
--- a/test/test/lux/lexer.clj
+++ /dev/null
@@ -1,276 +0,0 @@
-;;  Copyright (c) Eduardo Julian. All rights reserved.
-;;  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;;  If a copy of the MPL was not distributed with this file,
-;;  You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns test.lux.lexer
-  (:use clojure.test)
-  (:require (lux [base :as & :refer [|do return* return fail fail* |let |case]]
-                 [reader :as &reader]
-                 [lexer :as &lexer])
-            [lux.analyser.module :as &a-module]
-            :reload-all
-            ))
-
-;; [Utils]
-(def ^:private module-name "test")
-
-(defn ^:private make-state [source-code]
-  (&/set$ &/$source (&reader/from module-name source-code)
-          (&/init-state nil)))
-
-;; [Tests]
-(deftest lex-white-space
-  (let [input " \t"]
-    (|case (&/run-state &lexer/lex (make-state input))
-      (&/$Right state [cursor (&lexer/$White_Space output)])
-      (is (= input output))
-
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest lex-comment
-  ;; Should be capable of recognizing both single-line & multi-line comments.
-  (let [input1 " YOLO"
-        input2 "\nLOL\n"
-        input3 " NYAN\n#(\nCAT )#\n"]
-    (|case (&/run-state (|do [[_ single-line] &lexer/lex
-                              [_ multi-line] &lexer/lex
-                              [_ multi-line-embedded] &lexer/lex]
-                          (return (&/T [single-line multi-line multi-line-embedded])))
-                        (make-state (str "##" input1 "\n" "#(" input2 ")#" "\n" "#(" input3 ")#")))
-      (&/$Right state [(&lexer/$Comment output1)
-                       (&lexer/$Comment output2)
-                       (&lexer/$Comment output3)])
-      (are [input output] (= input output)
-           input1 output1
-           input2 output2
-           input3 output3)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest lex-bool
-  (let [input1 "true"
-        input2 "false"]
-    (|case (&/run-state (|do [[_ output1] &lexer/lex
-                              [_ output2] &lexer/lex]
-                          (return (&/T [output1 output2])))
-                        (make-state (str input1 "\n" input2)))
-      (&/$Right state [(&lexer/$Bool output1)
-                       (&lexer/$Bool output2)])
-      (are [input output] (= input output)
-           input1 output1
-           input2 output2)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest lex-int
-  (let [input1 "0"
-        input2 "12"
-        input3 "-123"]
-    (|case (&/run-state (|do [[_ output1] &lexer/lex
-                              [_ output2] &lexer/lex
-                              [_ output3] &lexer/lex]
-                          (return (&/T [output1 output2 output3])))
-                        (make-state (str input1 "\n" input2 "\n" input3)))
-      (&/$Right state [(&lexer/$Int output1)
-                       (&lexer/$Int output2)
-                       (&lexer/$Int output3)])
-      (are [input output] (= input output)
-           input1 output1
-           input2 output2
-           input3 output3)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest lex-real
-  (let [input1 "0.00123"
-        input2 "12.01020300"
-        input3 "-12.3"]
-    (|case (&/run-state (|do [[_ output1] &lexer/lex
-                              [_ output2] &lexer/lex
-                              [_ output3] &lexer/lex]
-                          (return (&/T [output1 output2 output3])))
-                        (make-state (str input1 "\n" input2 "\n" input3)))
-      (&/$Right state [(&lexer/$Real output1)
-                       (&lexer/$Real output2)
-                       (&lexer/$Real output3)])
-      (are [input output] (= input output)
-           input1 output1
-           input2 output2
-           input3 output3)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest lex-char
-  (let [input1 "a"
-        input2 "\\n"
-        input3 " "
-        input4 "\\t"
-        input5 "\\b"
-        input6 "\\r"
-        input7 "\\f"
-        input8 "\\\""
-        input9 "\\\\"]
-    (|case (&/run-state (|do [[_ output1] &lexer/lex
-                              [_ output2] &lexer/lex
-                              [_ output3] &lexer/lex
-                              [_ output4] &lexer/lex
-                              [_ output5] &lexer/lex
-                              [_ output6] &lexer/lex
-                              [_ output7] &lexer/lex
-                              [_ output8] &lexer/lex
-                              [_ output9] &lexer/lex]
-                          (return (&/T [output1 output2 output3 output4 output5 output6 output7 output8 output9])))
-                        (make-state (str "#\"" input1 "\"" "\n" "#\"" input2 "\"" "\n" "#\"" input3 "\""
-                                         "\n" "#\"" input4 "\"" "\n" "#\"" input5 "\"" "\n" "#\"" input6 "\""
-                                         "\n" "#\"" input7 "\"" "\n" "#\"" input8 "\"" "\n" "#\"" input9 "\"")))
-      (&/$Right state [(&lexer/$Char output1)
-                       (&lexer/$Char output2)
-                       (&lexer/$Char output3)
-                       (&lexer/$Char output4)
-                       (&lexer/$Char output5)
-                       (&lexer/$Char output6)
-                       (&lexer/$Char output7)
-                       (&lexer/$Char output8)
-                       (&lexer/$Char output9)])
-      (are [input output] (= input output)
-           input1 output1
-           "\n"   output2
-           input3 output3
-           "\t"   output4
-           "\b"   output5
-           "\r"   output6
-           "\f"   output7
-           "\""   output8
-           "\\"   output9)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest lex-text
-  (let [input1 ""
-        input2 "abc"
-        input3 "yolo\\nlol\\tmeme"
-        input4 "This is a test\\nof multi-line text.\\n\\nI just wanna make sure it works alright..."]
-    (|case (&/run-state (|do [[_ output1] &lexer/lex
-                              [_ output2] &lexer/lex
-                              [_ output3] &lexer/lex
-                              [_ output4] &lexer/lex]
-                          (return (&/T [output1 output2 output3 output4])))
-                        (make-state (str "\"" input1 "\"" "\n" "\"" input2 "\"" "\n" "\"" input3 "\"" "\n" "\"" input4 "\"")))
-      (&/$Right state [(&lexer/$Text output1)
-                       (&lexer/$Text output2)
-                       (&lexer/$Text output3)
-                       (&lexer/$Text output4)])
-      (are [input output] (= input output)
-           input1 output1
-           input2 output2
-           "yolo\nlol\tmeme" output3
-           "This is a test\nof multi-line text.\n\nI just wanna make sure it works alright..." output4)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest lex-symbol
-  (let [input1 "foo"
-        input2 "test;bar0123456789"
-        input3 ";b1a2z3"
-        input4 ";;quux"
-        input5 "!_@$%^&*-+=.<>?/|\\~`':"]
-    (|case (&/run-state (|do [_ (&a-module/enter-module module-name)
-                              [_ output1] &lexer/lex
-                              [_ output2] &lexer/lex
-                              [_ output3] &lexer/lex
-                              [_ output4] &lexer/lex
-                              [_ output5] &lexer/lex]
-                          (return (&/T [output1 output2 output3 output4 output5])))
-                        (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5 " ")))
-      (&/$Right state [(&lexer/$Symbol output1)
-                       (&lexer/$Symbol output2)
-                       (&lexer/$Symbol output3)
-                       (&lexer/$Symbol output4)
-                       (&lexer/$Symbol output5)])
-      (are [input output] (&/ident= input output)
-           (&/T ["" "foo"])                     output1
-           (&/T ["test" "bar0123456789"])       output2
-           (&/T ["lux" "b1a2z3"])               output3
-           (&/T ["test" "quux"])                output4
-           (&/T ["" "!_@$%^&*-+=.<>?/|\\~`':"]) output5)
-      
-      _
-      (is false "Couldn't read")
-      )))
-
-(deftest lex-tag
-  (let [input1 "foo"
-        input2 "test;bar0123456789"
-        input3 ";b1a2z3"
-        input4 ";;quux"
-        input5 "!_@$%^&*-+=.<>?/|\\~`':"]
-    (|case (&/run-state (|do [_ (&a-module/enter-module module-name)
-                              [_ output1] &lexer/lex
-                              [_ output2] &lexer/lex
-                              [_ output3] &lexer/lex
-                              [_ output4] &lexer/lex
-                              [_ output5] &lexer/lex]
-                          (return (&/T [output1 output2 output3 output4 output5])))
-                        (make-state (str "#" input1 "\n" "#" input2 "\n" "#" input3 "\n" "#" input4 "\n" "#" input5 " ")))
-      (&/$Right state [(&lexer/$Tag output1)
-                       (&lexer/$Tag output2)
-                       (&lexer/$Tag output3)
-                       (&lexer/$Tag output4)
-                       (&lexer/$Tag output5)])
-      (are [input output] (&/ident= input output)
-           (&/T ["" "foo"])                     output1
-           (&/T ["test" "bar0123456789"])       output2
-           (&/T ["lux" "b1a2z3"])               output3
-           (&/T ["test" "quux"])                output4
-           (&/T ["" "!_@$%^&*-+=.<>?/|\\~`':"]) output5)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest lex-delimiter
-  (let [input1 "("
-        input2 ")"
-        input3 "["
-        input4 "]"
-        input5 "{"
-        input6 "}"]
-    (|case (&/run-state (|do [_ (&a-module/enter-module module-name)
-                              [_ output1] &lexer/lex
-                              [_ output2] &lexer/lex
-                              [_ output3] &lexer/lex
-                              [_ output4] &lexer/lex
-                              [_ output5] &lexer/lex
-                              [_ output6] &lexer/lex]
-                          (return (&/T [output1 output2 output3 output4 output5 output6])))
-                        (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5 "\n" input6)))
-      (&/$Right state [(&lexer/$Open_Paren)
-                       (&lexer/$Close_Paren)
-                       (&lexer/$Open_Bracket)
-                       (&lexer/$Close_Bracket)
-                       (&lexer/$Open_Brace)
-                       (&lexer/$Close_Brace)])
-      (is true)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(comment
-  (run-all-tests)
-  )
diff --git a/test/test/lux/parser.clj b/test/test/lux/parser.clj
deleted file mode 100644
index 29e916b74..000000000
--- a/test/test/lux/parser.clj
+++ /dev/null
@@ -1,274 +0,0 @@
-;;  Copyright (c) Eduardo Julian. All rights reserved.
-;;  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;;  If a copy of the MPL was not distributed with this file,
-;;  You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns test.lux.parser
-  (:use (clojure test
-                 template))
-  (:require (lux [base :as & :refer [|do return* return fail fail* |let |case]]
-                 [reader :as &reader]
-                 [parser :as &parser])
-            [lux.analyser.module :as &a-module]
-            :reload-all))
-
-;; [Utils]
-(def ^:private module-name "test")
-
-(defn ^:private make-state [source-code]
-  (&/set$ &/$source (&reader/from module-name source-code)
-          (&/init-state nil)))
-
-;; [Tests]
-(deftest parse-white-space
-  (let [input " \t"]
-    (|case (&/run-state &parser/parse (make-state input))
-      (&/$Right state (&/$Nil))
-      (is true)
-
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest parse-comment
-  (let [input1 " YOLO"
-        input2 "\nLOL\n"
-        input3 " NYAN\n#(\nCAT )#\n"]
-    (|case (&/run-state &parser/parse (make-state (str "##" input1 "\n" "#(" input2 ")#" "\n" "#(" input3 ")#")))
-      (&/$Right state (&/$Nil))
-      (is true)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest parse-bool
-  (let [input1 "true"
-        input2 "false"]
-    (|case (&/run-state (|do [output1 &parser/parse
-                              output2 &parser/parse]
-                          (return (&/|++ output1 output2)))
-                        (make-state (str input1 "\n" input2)))
-      (&/$Right state (&/$Cons [_ (&/$BoolS output1)] (&/$Cons [_ (&/$BoolS output2)] (&/$Nil))))
-      (are [input output] (= input output)
-           true  output1
-           false output2)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest parse-int
-  (let [input1 "0"
-        input2 "12"
-        input3 "-123"]
-    (|case (&/run-state (|do [output1 &parser/parse
-                              output2 &parser/parse
-                              output3 &parser/parse]
-                          (return (&/|++ output1 (&/|++ output2 output3))))
-                        (make-state (str input1 "\n" input2 "\n" input3)))
-      (&/$Right state (&/$Cons [_ (&/$IntS output1)] (&/$Cons [_ (&/$IntS output2)] (&/$Cons [_ (&/$IntS output3)] (&/$Nil)))))
-      (are [input output] (= input output)
-           0    output1
-           12   output2
-           -123 output3)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest parse-real
-  (let [input1 "0.00123"
-        input2 "12.01020300"
-        input3 "-12.3"]
-    (|case (&/run-state (|do [output1 &parser/parse
-                              output2 &parser/parse
-                              output3 &parser/parse]
-                          (return (&/|++ output1 (&/|++ output2 output3))))
-                        (make-state (str input1 "\n" input2 "\n" input3)))
-      (&/$Right state (&/$Cons [_ (&/$RealS output1)] (&/$Cons [_ (&/$RealS output2)] (&/$Cons [_ (&/$RealS output3)] (&/$Nil)))))
-      (are [input output] (= input output)
-           0.00123   output1
-           12.010203 output2
-           -12.3     output3)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest parse-char
-  (let [input1 "a"
-        input2 "\\n"
-        input3 " "
-        input4 "\\t"
-        input5 "\\b"
-        input6 "\\r"
-        input7 "\\f"
-        input8 "\\\""
-        input9 "\\\\"]
-    (|case (&/run-state (|do [output1 &parser/parse
-                              output2 &parser/parse
-                              output3 &parser/parse
-                              output4 &parser/parse
-                              output5 &parser/parse
-                              output6 &parser/parse
-                              output7 &parser/parse
-                              output8 &parser/parse
-                              output9 &parser/parse]
-                          (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 (&/|++ output5 (&/|++ output6 (&/|++ output7 (&/|++ output8 output9))))))))))
-                        (make-state (str "#\"" input1 "\"" "\n" "#\"" input2 "\"" "\n" "#\"" input3 "\""
-                                         "\n" "#\"" input4 "\"" "\n" "#\"" input5 "\"" "\n" "#\"" input6 "\""
-                                         "\n" "#\"" input7 "\"" "\n" "#\"" input8 "\"" "\n" "#\"" input9 "\"")))
-      (&/$Right state (&/$Cons [_ (&/$CharS output1)]
-                               (&/$Cons [_ (&/$CharS output2)]
-                                        (&/$Cons [_ (&/$CharS output3)]
-                                                 (&/$Cons [_ (&/$CharS output4)]
-                                                          (&/$Cons [_ (&/$CharS output5)]
-                                                                   (&/$Cons [_ (&/$CharS output6)]
-                                                                            (&/$Cons [_ (&/$CharS output7)]
-                                                                                     (&/$Cons [_ (&/$CharS output8)]
-                                                                                              (&/$Cons [_ (&/$CharS output9)]
-                                                                                                       (&/$Nil)))))))))))
-      (are [input output] (= input output)
-           \a         output1
-           \newline   output2
-           \space     output3
-           \tab       output4
-           \backspace output5
-           \return    output6
-           \formfeed  output7
-           \"         output8
-           \\         output9)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest parse-text
-  (let [input1 ""
-        input2 "abc"
-        input3 "yolo\\nlol\\tmeme"
-        input4 "This is a test\\nof multi-line text.\\n\\nI just wanna make sure it works alright..."]
-    (|case (&/run-state (|do [output1 &parser/parse
-                              output2 &parser/parse
-                              output3 &parser/parse
-                              output4 &parser/parse]
-                          (return (&/|++ output1 (&/|++ output2 (&/|++ output3 output4)))))
-                        (make-state (str "\"" input1 "\"" "\n" "\"" input2 "\"" "\n" "\"" input3 "\"" "\n" "\"" input4 "\"")))
-      (&/$Right state (&/$Cons [_ (&/$TextS output1)] (&/$Cons [_ (&/$TextS output2)] (&/$Cons [_ (&/$TextS output3)] (&/$Cons [_ (&/$TextS output4)] (&/$Nil))))))
-      (are [input output] (= input output)
-           input1            output1
-           input2            output2
-           "yolo\nlol\tmeme" output3
-           "This is a test\nof multi-line text.\n\nI just wanna make sure it works alright..." output4)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest parse-symbol
-  (let [input1 "foo"
-        input2 "test;bar0123456789"
-        input3 ";b1a2z3"
-        input4 ";;quux"
-        input5 "!_@$%^&*-+=.<>?/|\\~`':"]
-    (|case (&/run-state (|do [_ (&a-module/enter-module module-name)
-                              output1 &parser/parse
-                              output2 &parser/parse
-                              output3 &parser/parse
-                              output4 &parser/parse
-                              output5 &parser/parse]
-                          (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 output5))))))
-                        (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5 " ")))
-      (&/$Right state (&/$Cons [_ (&/$SymbolS output1)]
-                               (&/$Cons [_ (&/$SymbolS output2)]
-                                        (&/$Cons [_ (&/$SymbolS output3)]
-                                                 (&/$Cons [_ (&/$SymbolS output4)]
-                                                          (&/$Cons [_ (&/$SymbolS output5)]
-                                                                   (&/$Nil)))))))
-      (are [input output] (&/ident= input output)
-           (&/T ["" "foo"])                     output1
-           (&/T ["test" "bar0123456789"])       output2
-           (&/T ["lux" "b1a2z3"])               output3
-           (&/T ["test" "quux"])                output4
-           (&/T ["" "!_@$%^&*-+=.<>?/|\\~`':"]) output5)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest parse-tag
-  (let [input1 "foo"
-        input2 "test;bar0123456789"
-        input3 ";b1a2z3"
-        input4 ";;quux"
-        input5 "!_@$%^&*-+=.<>?/|\\~`':"]
-    (|case (&/run-state (|do [_ (&a-module/enter-module module-name)
-                              output1 &parser/parse
-                              output2 &parser/parse
-                              output3 &parser/parse
-                              output4 &parser/parse
-                              output5 &parser/parse]
-                          (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 output5))))))
-                        (make-state (str "#" input1 "\n" "#" input2 "\n" "#" input3 "\n" "#" input4 "\n" "#" input5 " ")))
-      (&/$Right state (&/$Cons [_ (&/$TagS output1)]
-                               (&/$Cons [_ (&/$TagS output2)]
-                                        (&/$Cons [_ (&/$TagS output3)]
-                                                 (&/$Cons [_ (&/$TagS output4)]
-                                                          (&/$Cons [_ (&/$TagS output5)]
-                                                                   (&/$Nil)))))))
-      (are [input output] (&/ident= input output)
-           (&/T ["" "foo"])                     output1
-           (&/T ["test" "bar0123456789"])       output2
-           (&/T ["lux" "b1a2z3"])               output3
-           (&/T ["test" "quux"])                output4
-           (&/T ["" "!_@$%^&*-+=.<>?/|\\~`':"]) output5)
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(do-template [   ]
-  (deftest 
-    (let [input1 "yolo 123 \"lol\" #meme"]
-      (|case (&/run-state &parser/parse
-                          (make-state (str  input1 )))
-        (&/$Right state (&/$Cons [_ ( (&/$Cons [_ (&/$SymbolS symv)]
-                                                    (&/$Cons [_ (&/$IntS intv)]
-                                                             (&/$Cons [_ (&/$TextS textv)]
-                                                                      (&/$Cons [_ (&/$TagS tagv)]
-                                                                               (&/$Nil))))))]
-                                 (&/$Nil)))
-        (do (is (&/ident= (&/T ["" "yolo"]) symv))
-          (is (= 123 intv))
-          (is (= "lol" textv))
-          (is (&/ident= (&/T ["" "meme"]) tagv)))
-        
-        _
-        (is false "Couldn't read.")
-        )))
-
-  parse-form  &/$FormS  "(" ")"
-  parse-tuple &/$TupleS "[" "]"
-  )
-
-(deftest parse-record
-  (let [input1 "yolo 123 \"lol\" #meme"]
-    (|case (&/run-state &parser/parse
-                        (make-state (str "{" input1 "}")))
-      (&/$Right state (&/$Cons [_ (&/$RecordS (&/$Cons [[_ (&/$SymbolS symv)] [_ (&/$IntS intv)]]
-                                                       (&/$Cons [[_ (&/$TextS textv)] [_ (&/$TagS tagv)]]
-                                                                (&/$Nil))))]
-                               (&/$Nil)))
-      (do (is (&/ident= (&/T ["" "yolo"]) symv))
-        (is (= 123 intv))
-        (is (= "lol" textv))
-        (is (&/ident= (&/T ["" "meme"]) tagv)))
-      
-      _
-      (is false "Couldn't read.")
-      )))
-
-(comment
-  (run-all-tests)
-  )
diff --git a/test/test/lux/reader.clj b/test/test/lux/reader.clj
deleted file mode 100644
index ee9cb4c35..000000000
--- a/test/test/lux/reader.clj
+++ /dev/null
@@ -1,53 +0,0 @@
-;;  Copyright (c) Eduardo Julian. All rights reserved.
-;;  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;;  If a copy of the MPL was not distributed with this file,
-;;  You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns test.lux.reader
-  (:use clojure.test)
-  (:require (lux [base :as & :refer [|do return* return fail fail* |let |case]]
-                 [reader :as &reader])
-            :reload-all))
-
-;; [Utils]
-(def source (&reader/from "test" "lol\nmeme\nnyan cat\n\nlolcat"))
-(def init-state (&/set$ &/$source source (&/init-state nil)))
-
-;; [Tests]
-(deftest test-source-code-reading
-  (is (= 5 (&/|length source))))
-
-(deftest test-text-reading
-  ;; Should be capable of recognizing literal texts.
-  (let [input "lo"]
-    (|case (&/run-state (&reader/read-text input) init-state)
-      (&/$Right state [cursor end-line? output])
-      (is (= input output))
-
-      _
-      (is false "Couldn't read.")
-      )))
-
-(deftest test-regex-reading
-  ;; Should be capable of matching simple, grouping regex-patterns.
-  (|case (&/run-state (&reader/read-regex #"l(.)l") init-state)
-    (&/$Right state [cursor end-line? output])
-    (is (= "lol" output))
-
-    _
-    (is false "Couldn't read.")
-    ))
-
-(deftest test-regex+-reading
-  ;; Should be capable of matching multi-line regex-patterns.
-  (|case (&/run-state (&reader/read-regex+ #"(?is)^((?!cat).)*") init-state)
-    (&/$Right state [cursor output])
-    (is (= "\nlol\nmeme\nnyan " output))
-
-    _
-    (is false "Couldn't read.")
-    ))
-
-(comment
-  (run-all-tests)
-  )
diff --git a/test/test/lux/type.clj b/test/test/lux/type.clj
deleted file mode 100644
index 1a43f7cc4..000000000
--- a/test/test/lux/type.clj
+++ /dev/null
@@ -1,473 +0,0 @@
-;;  Copyright (c) Eduardo Julian. All rights reserved.
-;;  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;;  If a copy of the MPL was not distributed with this file,
-;;  You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns test.lux.type
-  (:use clojure.test)
-  (:require (lux [base :as & :refer [|do return* return fail fail* |let |case]]
-                 [type :as &type])
-            :reload-all
-            ))
-
-;; [Tests]
-(deftest check-base-types
-  (|case (&/run-state (|do [_ (&type/check &/$UnitT &/$UnitT)
-
-                            _ (&type/check &/$VoidT &/$VoidT)]
-                        (return nil))
-                      (&/init-state nil))
-    (&/$Right state nil)
-    (is true)
-    
-    (&/$Left error)
-    (is false error)
-    ))
-
-(deftest check-simple-host-types
-  (|case (&/run-state (|do [_ (&type/check (&/$HostT "java.lang.Boolean" &/$Nil)
-                                           (&/$HostT "java.lang.Boolean" &/$Nil))
-                            
-                            _ (&type/check (&/$HostT "java.lang.Object" &/$Nil)
-                                           (&/$HostT "java.lang.Boolean" &/$Nil))]
-                        (return nil))
-                      (&/init-state nil))
-    (&/$Right state nil)
-    (is true)
-    
-    (&/$Left error)
-    (is false error)
-    ))
-
-(deftest check-complex-host-types
-  (|case (&/run-state (|do [_ (&type/check (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil)))
-                                           (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil))))
-                            
-                            _ (&type/check (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Object" &/$Nil)))
-                                           (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil))))
-
-                            _ (&type/check (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil)))
-                                           (&/$HostT "java.util.ArrayList" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil))))]
-                        (return nil))
-                      (&/init-state nil))
-    (&/$Right state nil)
-    (is true)
-    
-    (&/$Left error)
-    (is false error)
-    ))
-
-(deftest check-named-types
-  (|case (&/run-state (|do [_ (&type/check (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil))
-                                           (&/$HostT "java.lang.Boolean" &/$Nil))
-                            
-                            _ (&type/check (&/$HostT "java.lang.Boolean" &/$Nil)
-                                           (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil)))
-                            
-                            _ (&type/check (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil))
-                                           (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil)))]
-                        (return nil))
-                      (&/init-state nil))
-    (&/$Right state nil)
-    (is true)
-    
-    (&/$Left error)
-    (is false error)
-    ))
-
-(deftest check-sum-types
-  (|case (&/run-state (|do [_ (&type/check (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                    (&/$HostT "java.lang.Boolean" &/$Nil))
-                                           (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                    (&/$HostT "java.lang.Boolean" &/$Nil)))
-
-                            _ (&type/check (&/$SumT (&/$HostT "java.lang.Object" &/$Nil)
-                                                    (&/$HostT "java.lang.Boolean" &/$Nil))
-                                           (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                    (&/$HostT "java.lang.Boolean" &/$Nil)))
-
-                            _ (&type/check (&/$SumT (&/$HostT "java.lang.Object" &/$Nil)
-                                                    (&/$HostT "java.lang.Object" &/$Nil))
-                                           (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                    (&/$HostT "java.lang.Boolean" &/$Nil)))
-
-                            _ (&type/check (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                    (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                             (&/$HostT "java.lang.Boolean" &/$Nil)))
-                                           (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                    (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                             (&/$HostT "java.lang.Boolean" &/$Nil))))
-
-                            _ (&type/check (&/$SumT (&/$HostT "java.lang.Object" &/$Nil)
-                                                    (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                             (&/$HostT "java.lang.Boolean" &/$Nil)))
-                                           (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                    (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                             (&/$HostT "java.lang.Boolean" &/$Nil))))
-
-                            _ (&type/check (&/$SumT (&/$HostT "java.lang.Object" &/$Nil)
-                                                    (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                             (&/$HostT "java.lang.Object" &/$Nil)))
-                                           (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                    (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                             (&/$HostT "java.lang.Boolean" &/$Nil))))]
-                        (return nil))
-                      (&/init-state nil))
-    (&/$Right state nil)
-    (is true)
-    
-    (&/$Left error)
-    (is false error)
-    ))
-
-(deftest check-prod-types
-  (|case (&/run-state (|do [_ (&type/check (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                     (&/$HostT "java.lang.Boolean" &/$Nil))
-                                           (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                     (&/$HostT "java.lang.Boolean" &/$Nil)))
-
-                            _ (&type/check (&/$ProdT (&/$HostT "java.lang.Object" &/$Nil)
-                                                     (&/$HostT "java.lang.Boolean" &/$Nil))
-                                           (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                     (&/$HostT "java.lang.Boolean" &/$Nil)))
-
-                            _ (&type/check (&/$ProdT (&/$HostT "java.lang.Object" &/$Nil)
-                                                     (&/$HostT "java.lang.Object" &/$Nil))
-                                           (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                     (&/$HostT "java.lang.Boolean" &/$Nil)))
-
-                            _ (&type/check (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                     (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                               (&/$HostT "java.lang.Boolean" &/$Nil)))
-                                           (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                     (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                               (&/$HostT "java.lang.Boolean" &/$Nil))))
-
-                            _ (&type/check (&/$ProdT (&/$HostT "java.lang.Object" &/$Nil)
-                                                     (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                               (&/$HostT "java.lang.Boolean" &/$Nil)))
-                                           (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                     (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                               (&/$HostT "java.lang.Boolean" &/$Nil))))
-
-                            _ (&type/check (&/$ProdT (&/$HostT "java.lang.Object" &/$Nil)
-                                                     (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                               (&/$HostT "java.lang.Object" &/$Nil)))
-                                           (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                     (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                               (&/$HostT "java.lang.Boolean" &/$Nil))))]
-                        (return nil))
-                      (&/init-state nil))
-    (&/$Right state nil)
-    (is true)
-    
-    (&/$Left error)
-    (is false error)
-    ))
-
-(deftest check-lambda-types
-  (|case (&/run-state (|do [_ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                       (&/$HostT "java.lang.Boolean" &/$Nil))
-                                           (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                       (&/$HostT "java.lang.Boolean" &/$Nil)))
-
-                            _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                       (&/$HostT "java.lang.Boolean" &/$Nil))
-                                           (&/$LambdaT (&/$HostT "java.lang.Object" &/$Nil)
-                                                       (&/$HostT "java.lang.Boolean" &/$Nil)))
-
-                            _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                       (&/$HostT "java.lang.Object" &/$Nil))
-                                           (&/$LambdaT (&/$HostT "java.lang.Object" &/$Nil)
-                                                       (&/$HostT "java.lang.Boolean" &/$Nil)))
-                            
-                            _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                       (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                                   (&/$HostT "java.lang.Boolean" &/$Nil)))
-                                           (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                       (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                                   (&/$HostT "java.lang.Boolean" &/$Nil))))
-
-                            _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                       (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                                   (&/$HostT "java.lang.Boolean" &/$Nil)))
-                                           (&/$LambdaT (&/$HostT "java.lang.Object" &/$Nil)
-                                                       (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                                   (&/$HostT "java.lang.Boolean" &/$Nil))))
-
-                            _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                       (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                                   (&/$HostT "java.lang.Object" &/$Nil)))
-                                           (&/$LambdaT (&/$HostT "java.lang.Object" &/$Nil)
-                                                       (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil)
-                                                                   (&/$HostT "java.lang.Boolean" &/$Nil))))
-                            ]
-                        (return nil))
-                      (&/init-state nil))
-    (&/$Right state nil)
-    (is true)
-    
-    (&/$Left error)
-    (is false error)
-    ))
-
-(deftest check-ex-types
-  (|case (&/run-state (|do [_ (&type/check (&/$ExT 0) (&/$ExT 0))]
-                        (return nil))
-                      (&/init-state nil))
-    (&/$Right state nil)
-    (is true)
-    
-    (&/$Left error)
-    (is false error)
-    ))
-
-(deftest check-univ-quantification
-  (|case (&/run-state (|do [_ (&type/check (&/$UnivQ (&/|list)
-                                                     (&/$LambdaT &/$VoidT (&/$BoundT 1)))
-                                           (&/$UnivQ (&/|list)
-                                                     (&/$LambdaT &/$VoidT (&/$BoundT 1))))
-
-                            _ (&type/check (&/$UnivQ (&/|list)
-                                                     (&/$SumT
-                                                      ;; lux;None
-                                                      &/$UnitT
-                                                      ;; lux;Some
-                                                      (&/$BoundT 1)))
-                                           (&/$UnivQ (&/|list)
-                                                     (&/$SumT
-                                                      ;; lux;None
-                                                      &/$UnitT
-                                                      ;; lux;Some
-                                                      (&/$BoundT 1))))
-
-                            _ (&type/check (&/$UnivQ (&/|list)
-                                                     (&/$SumT
-                                                      ;; lux;Nil
-                                                      &/$UnitT
-                                                      ;; lux;Cons
-                                                      (&/$ProdT (&/$BoundT 1)
-                                                                (&/$AppT (&/$BoundT 0)
-                                                                         (&/$BoundT 1)))))
-                                           (&/$UnivQ (&/|list)
-                                                     (&/$SumT
-                                                      ;; lux;Nil
-                                                      &/$UnitT
-                                                      ;; lux;Cons
-                                                      (&/$ProdT (&/$BoundT 1)
-                                                                (&/$AppT (&/$BoundT 0)
-                                                                         (&/$BoundT 1))))))]
-                        (return nil))
-                      (&/init-state nil))
-    (&/$Right state nil)
-    (is true)
-    
-    (&/$Left error)
-    (is false error)
-    ))
-
-(deftest check-ex-quantification
-  (|case (&/run-state (|do [_ (&type/check (&/$ExQ (&/|list)
-                                                   (&/$LambdaT &/$VoidT (&/$BoundT 1)))
-                                           (&/$ExQ (&/|list)
-                                                   (&/$LambdaT &/$VoidT (&/$BoundT 1))))
-
-                            _ (&type/check (&/$ExQ (&/|list)
-                                                   (&/$SumT
-                                                    ;; lux;None
-                                                    &/$UnitT
-                                                    ;; lux;Some
-                                                    (&/$BoundT 1)))
-                                           (&/$ExQ (&/|list)
-                                                   (&/$SumT
-                                                    ;; lux;None
-                                                    &/$UnitT
-                                                    ;; lux;Some
-                                                    (&/$BoundT 1))))
-
-                            _ (&type/check (&/$ExQ (&/|list)
-                                                   (&/$SumT
-                                                    ;; lux;Nil
-                                                    &/$UnitT
-                                                    ;; lux;Cons
-                                                    (&/$ProdT (&/$BoundT 1)
-                                                              (&/$AppT (&/$BoundT 0)
-                                                                       (&/$BoundT 1)))))
-                                           (&/$ExQ (&/|list)
-                                                   (&/$SumT
-                                                    ;; lux;Nil
-                                                    &/$UnitT
-                                                    ;; lux;Cons
-                                                    (&/$ProdT (&/$BoundT 1)
-                                                              (&/$AppT (&/$BoundT 0)
-                                                                       (&/$BoundT 1))))))]
-                        (return nil))
-                      (&/init-state nil))
-    (&/$Right state nil)
-    (is true)
-    
-    (&/$Left error)
-    (is false error)
-    ))
-
-(deftest check-app-type
-  (|case (&/run-state (|do [_ (&type/check (&/$AppT (&/$UnivQ (&/|list)
-                                                              (&/$LambdaT &/$VoidT (&/$BoundT 1)))
-                                                    (&/$HostT "java.lang.Boolean" &/$Nil))
-                                           (&/$AppT (&/$UnivQ (&/|list)
-                                                              (&/$LambdaT &/$VoidT (&/$BoundT 1)))
-                                                    (&/$HostT "java.lang.Boolean" &/$Nil)))
-
-                            _ (&type/check (&/$AppT (&/$UnivQ (&/|list)
-                                                              (&/$SumT
-                                                               ;; lux;None
-                                                               &/$UnitT
-                                                               ;; lux;Some
-                                                               (&/$BoundT 1)))
-                                                    (&/$HostT "java.lang.Object" &/$Nil))
-                                           (&/$AppT (&/$UnivQ (&/|list)
-                                                              (&/$SumT
-                                                               ;; lux;None
-                                                               &/$UnitT
-                                                               ;; lux;Some
-                                                               (&/$BoundT 1)))
-                                                    (&/$HostT "java.lang.Boolean" &/$Nil)))
-
-                            _ (&type/check (&/$AppT (&/$ExQ (&/|list)
-                                                            (&/$LambdaT &/$VoidT (&/$BoundT 1)))
-                                                    (&/$HostT "java.lang.Boolean" &/$Nil))
-                                           (&/$AppT (&/$ExQ (&/|list)
-                                                            (&/$LambdaT &/$VoidT (&/$BoundT 1)))
-                                                    (&/$HostT "java.lang.Boolean" &/$Nil)))
-
-                            _ (&type/check (&/$AppT (&/$ExQ (&/|list)
-                                                            (&/$SumT
-                                                             ;; lux;None
-                                                             &/$UnitT
-                                                             ;; lux;Some
-                                                             (&/$BoundT 1)))
-                                                    (&/$HostT "java.lang.Object" &/$Nil))
-                                           (&/$AppT (&/$ExQ (&/|list)
-                                                            (&/$SumT
-                                                             ;; lux;None
-                                                             &/$UnitT
-                                                             ;; lux;Some
-                                                             (&/$BoundT 1)))
-                                                    (&/$HostT "java.lang.Boolean" &/$Nil)))]
-                        (return nil))
-                      (&/init-state nil))
-    (&/$Right state nil)
-    (is true)
-    
-    (&/$Left error)
-    (is false error)
-    ))
-
-(deftest check-var-type
-  (|case (&/run-state (|do [_ (&type/with-var
-                                (fn [$var]
-                                  (|do [_ (&type/check $var (&/$HostT "java.lang.Boolean" &/$Nil))
-                                        (&/$HostT "java.lang.Boolean" (&/$Nil)) (&type/deref+ $var)]
-                                    (return nil))))
-
-                            _ (&type/with-var
-                                (fn [$var]
-                                  (|do [_ (&type/check (&/$AppT (&/$UnivQ (&/|list)
-                                                                          (&/$LambdaT &/$VoidT (&/$BoundT 1)))
-                                                                $var)
-                                                       (&/$AppT (&/$UnivQ (&/|list)
-                                                                          (&/$LambdaT &/$VoidT (&/$BoundT 1)))
-                                                                (&/$HostT "java.lang.Boolean" &/$Nil)))
-                                        (&/$HostT "java.lang.Boolean" (&/$Nil)) (&type/deref+ $var)]
-                                    (return nil))))
-
-                            _ (&type/with-var
-                                (fn [$var]
-                                  (|do [_ (&type/check (&/$HostT "java.lang.Boolean" &/$Nil) $var)
-                                        (&/$HostT "java.lang.Boolean" (&/$Nil)) (&type/deref+ $var)]
-                                    (return nil))))
-
-                            _ (&type/with-var
-                                (fn [$var]
-                                  (|do [_ (&type/check (&/$AppT (&/$UnivQ (&/|list)
-                                                                          (&/$LambdaT &/$VoidT (&/$BoundT 1)))
-                                                                (&/$HostT "java.lang.Boolean" &/$Nil))
-                                                       (&/$AppT (&/$UnivQ (&/|list)
-                                                                          (&/$LambdaT &/$VoidT (&/$BoundT 1)))
-                                                                $var))
-                                        (&/$HostT "java.lang.Boolean" (&/$Nil)) (&type/deref+ $var)]
-                                    (return nil))))
-
-                            _ (&type/with-var
-                                (fn [$var1]
-                                  (&type/with-var
-                                    (fn [$var2]
-                                      (|do [_ (&type/check $var1 $var2)]
-                                        (return nil))))))
-
-                            _ (&type/with-var
-                                (fn [$var1]
-                                  (&type/with-var
-                                    (fn [$var2]
-                                      (|do [_ (&type/check $var2 $var1)]
-                                        (return nil))))))
-
-                            _ (&type/with-var
-                                (fn [$var1]
-                                  (&type/with-var
-                                    (fn [$var2]
-                                      (|do [_ (&type/check $var1 $var2)
-                                            _ (&type/check $var1 (&/$HostT "java.lang.Boolean" (&/|list)))
-                                            =var1 (&type/deref+ $var1)
-                                            _ (&/assert! (&type/type= =var1 $var2) "")
-                                            =var2 (&type/deref+ $var2)
-                                            _ (&/assert! (&type/type= =var2 (&/$HostT "java.lang.Boolean" (&/|list))) "")]
-                                        (return nil))))))
-
-                            _ (&type/with-var
-                                (fn [$var1]
-                                  (&type/with-var
-                                    (fn [$var2]
-                                      (|do [_ (&type/check $var2 $var1)
-                                            _ (&type/check $var1 (&/$HostT "java.lang.Boolean" (&/|list)))
-                                            =var2 (&type/deref+ $var2)
-                                            _ (&/assert! (&type/type= =var2 $var1) "")
-                                            =var1 (&type/deref+ $var1)
-                                            _ (&/assert! (&type/type= =var1 (&/$HostT "java.lang.Boolean" (&/|list))) "")]
-                                        (return nil))))))
-                            
-                            _ (&type/with-var
-                                (fn [$var1]
-                                  (&type/with-var
-                                    (fn [$var2]
-                                      (|do [_ (&type/check $var1 $var2)
-                                            _ (&type/check $var2 (&/$HostT "java.lang.Boolean" (&/|list)))
-                                            =var1 (&type/deref+ $var1)
-                                            _ (&/assert! (&type/type= =var1 $var2) "")
-                                            =var2 (&type/deref+ $var2)
-                                            _ (&/assert! (&type/type= =var2 (&/$HostT "java.lang.Boolean" (&/|list))) "")]
-                                        (return nil))))))
-
-                            _ (&type/with-var
-                                (fn [$var1]
-                                  (&type/with-var
-                                    (fn [$var2]
-                                      (|do [_ (&type/check $var2 $var1)
-                                            _ (&type/check $var2 (&/$HostT "java.lang.Boolean" (&/|list)))
-                                            =var2 (&type/deref+ $var2)
-                                            _ (&/assert! (&type/type= =var2 $var1) "")
-                                            =var1 (&type/deref+ $var1)
-                                            _ (&/assert! (&type/type= =var1 (&/$HostT "java.lang.Boolean" (&/|list))) "")]
-                                        (return nil))))))]
-                        (return nil))
-                      (&/init-state nil))
-    (&/$Right state nil)
-    (is true)
-    
-    (&/$Left error)
-    (is false error)
-    ))
-
-(comment
-  (run-all-tests)
-  )
-- 
cgit v1.2.3